├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── examples ├── colorings.jace └── jealous.jace ├── jace.cabal ├── src ├── ASTUtils.hs ├── Lexer.hs ├── Lib.hs ├── Parser.hs ├── Transformer.hs ├── Validator.hs └── Writer.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | /.stack-work/ 2 | /ignore -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Andre Medeiros (c) 2016-2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # **J**ust **a**nother **c**ompiler **e**xperiment 2 | 3 | > Results of some personal holiday hacking session 4 | 5 | This project is a compiler written in Haskell for a Datalog-like DSL that generates JavaScript (ES5/CommonJS) code which uses the [LogicJS library](https://github.com/mcsoto/LogicJS) to perform logic deductions. 6 | 7 | The language is basically Datalog with: `:-` replaced with `if`, `,` replaced with `and`, and no mixed extensional/intensional predicates (only pure rules or pure facts allowed). 8 | 9 | ## Example 10 | 11 | ``` 12 | loves(vincent,mia). 13 | loves(marsellus,mia). 14 | loves(pumpkin,honeyBunny). 15 | loves(honeyBunny,pumpkin). 16 | 17 | jealous(X,Y) if loves(X,Z) and loves(Y,Z). 18 | 19 | evaluate jealous(marsellus,W). 20 | ``` 21 | 22 | When running the compiler, it generates the following code: 23 | 24 | ```js 25 | var $logic = require('logicjs'); 26 | var $or = $logic.or, $and = $logic.and, $eq = $logic.eq, $lvar = $logic.lvar; 27 | function $report(t, vns, vss){console.log('evaluate '+t+':\n'+vss.map(function(vs,j){return' '+(j+1)+'. '+vs.map(function(v,i){return vns[i]+'='+v;}).join(', ');}).join('\n'));} 28 | 29 | function loves(X1, X2) { 30 | return $or( 31 | $and($eq(X1, 'vincent'), $eq(X2, 'mia')), 32 | $and($eq(X1, 'marsellus'), $eq(X2, 'mia')), 33 | $and($eq(X1, 'pumpkin'), $eq(X2, 'honeyBunny')), 34 | $and($eq(X1, 'honeyBunny'), $eq(X2, 'pumpkin')) 35 | ); 36 | } 37 | 38 | function jealous(X, Y) { 39 | var Z = $lvar(); 40 | return $and(loves(X, Z), loves(Y, Z)); 41 | } 42 | 43 | var W = $lvar(); 44 | $report('jealous(marsellus,W)', ['W'], $logic.run(jealous('marsellus',W), [W])); 45 | ``` 46 | 47 | Which can be executed in Node.js to output: 48 | 49 | ``` 50 | evaluate jealous(marsellus,W): 51 | 1. W=vincent 52 | 2. W=marsellus 53 | ``` 54 | 55 | ## Syntax 56 | 57 | Facts: 58 | 59 | ``` 60 | loves(vincent,mia). 61 | ``` 62 | 63 | ``` 64 | height(andre,177). 65 | ``` 66 | 67 | ``` 68 | hungry(andre). 69 | ``` 70 | 71 | Rules: 72 | ``` 73 | jealous(X,Y) if loves(X,Z) and loves(Y,Z). 74 | ``` 75 | 76 | ``` 77 | conflict(R1, R2, Coloring) if 78 | adjacent(R1, R2) and 79 | color(R1, Color, Coloring) and 80 | color(R2, Color, Coloring). 81 | ``` 82 | 83 | Evaluations: 84 | 85 | ``` 86 | evaluate hungry(X). 87 | ``` 88 | 89 | ``` 90 | evaluate conflictingAreas(X,Y). 91 | ``` 92 | 93 | ## Disclaimer 94 | 95 | This compiler and the runtime is probably broken in a bunch of ways, e.g. recursive rules blow up when evaluated. It doesn't matter, this is just a hobby project to give Haskell a test drive. Probably also my Haskell code is naive in a couple of ways. 96 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib (compile) 4 | import System.Environment (getArgs) 5 | import Data.Text (toUpper, pack, unpack) 6 | import Debug.Trace (trace) 7 | 8 | (|>) = flip ($) 9 | 10 | main :: IO () 11 | main = do 12 | args <- getArgs 13 | if length args > 0 then do 14 | let inputFileName = head args 15 | inputFileContents <- readFile inputFileName 16 | inputFileContents |> compile |> putStrLn 17 | else 18 | putStrLn "Please provide an input file as an argument to this program" 19 | -------------------------------------------------------------------------------- /examples/colorings.jace: -------------------------------------------------------------------------------- 1 | adjacent(1,2). adjacent(2,1). 2 | adjacent(1,3). adjacent(3,1). 3 | adjacent(1,4). adjacent(4,1). 4 | adjacent(1,5). adjacent(5,1). 5 | adjacent(2,3). adjacent(3,2). 6 | adjacent(2,4). adjacent(4,2). 7 | adjacent(3,4). adjacent(4,3). 8 | adjacent(4,5). adjacent(5,4). 9 | 10 | color(1,red,a). color(1,red,b). 11 | color(2,blue,a). color(2,blue,b). 12 | color(3,green,a). color(3,green,b). 13 | color(4,yellow,a). color(4,blue,b). 14 | color(5,blue,a). color(5,green,b). 15 | 16 | conflict(R1,R2,Coloring) if 17 | adjacent(R1,R2) and 18 | color(R1,Color,Coloring) and 19 | color(R2,Color,Coloring). 20 | 21 | conflictingAreas(R1,R2) if 22 | conflict(R1,R2,Coloring). 23 | 24 | evaluate conflictingAreas(X,Y). -------------------------------------------------------------------------------- /examples/jealous.jace: -------------------------------------------------------------------------------- 1 | woman(mia). 2 | woman(jody). 3 | woman(yolanda). 4 | 5 | loves(vincent,mia). 6 | loves(marsellus,mia). 7 | loves(pumpkin,honeyBunny). 8 | loves(honeyBunny,pumpkin). 9 | 10 | jealous(X,Y) if loves(X,Z) and loves(Y,Z). 11 | 12 | evaluate woman(X). 13 | evaluate jealous(marsellus,W). -------------------------------------------------------------------------------- /jace.cabal: -------------------------------------------------------------------------------- 1 | name: jace 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/githubuser/jace#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Andre Medeiros 9 | maintainer: example@example.com 10 | copyright: 2016 Andre Medeiros 11 | category: Web 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Lib 19 | , Lexer 20 | , Parser 21 | , Validator 22 | , Transformer 23 | , Writer 24 | , ASTUtils 25 | build-depends: base >= 4.7 && < 5 26 | , text 27 | , parsec 28 | , containers 29 | default-language: Haskell2010 30 | 31 | executable jace-exe 32 | hs-source-dirs: app 33 | main-is: Main.hs 34 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 35 | build-depends: base 36 | , text 37 | , jace 38 | default-language: Haskell2010 39 | 40 | test-suite jace-test 41 | type: exitcode-stdio-1.0 42 | hs-source-dirs: test 43 | main-is: Spec.hs 44 | build-depends: base 45 | , jace 46 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 47 | default-language: Haskell2010 48 | 49 | source-repository head 50 | type: git 51 | location: https://github.com/staltz/jace 52 | -------------------------------------------------------------------------------- /src/ASTUtils.hs: -------------------------------------------------------------------------------- 1 | module ASTUtils ( 2 | isFact, 3 | isRule, 4 | isEvaluation, 5 | isVariable, 6 | groupByRelation, 7 | inferRelationArity, 8 | ) where 9 | 10 | import Parser (AST(..), Term(..), Relation(..)) 11 | import qualified Data.Map as Map 12 | 13 | (|>) = flip ($) 14 | 15 | isFact :: AST -> Bool 16 | isFact (Fact _) = True 17 | isFact _ = False 18 | 19 | isRule :: AST -> Bool 20 | isRule (Rule _ _) = True 21 | isRule _ = False 22 | 23 | isEvaluation :: AST -> Bool 24 | isEvaluation (Evaluation _) = True 25 | isEvaluation _ = False 26 | 27 | isVariable :: Term -> Bool 28 | isVariable (Variable _) = True 29 | isVariable _ = False 30 | 31 | groupByRelation :: [AST] -> [(String, [AST])] 32 | groupByRelation astList = 33 | astList 34 | |> keyify 35 | |> sortAndGroup 36 | |> Map.toList 37 | 38 | where 39 | keyify :: [AST] -> [(String, AST)] 40 | keyify (ast : rest) = 41 | case ast of 42 | Fact (Relation name _) -> (name, ast) : (keyify rest) 43 | Rule (Relation name _) _ -> (name, ast) : (keyify rest) 44 | Evaluation (Relation name _) -> (name, ast) : (keyify rest) 45 | keyify [] = [] 46 | 47 | sortAndGroup :: [(String, AST)] -> Map.Map String [AST] 48 | sortAndGroup assocs = Map.fromListWith (++) [(k, [v]) | (k, v) <- assocs] 49 | 50 | inferRelationArity :: AST -> Int 51 | inferRelationArity ast = 52 | case ast of 53 | Fact (Relation _ terms) -> length terms 54 | Rule (Relation _ terms) _ -> length terms 55 | Evaluation (Relation _ terms) -> length terms 56 | -------------------------------------------------------------------------------- /src/Lexer.hs: -------------------------------------------------------------------------------- 1 | module Lexer (Token(..), tokenize) where 2 | 3 | import qualified Text.Parsec as Parsec 4 | import Data.List (intersperse) 5 | 6 | (|>) = flip ($) 7 | 8 | data Token = 9 | ParenOpenToken | 10 | ParenCloseToken | 11 | NameToken String | 12 | VarToken String | 13 | IntToken Int | 14 | EvalToken | 15 | IfToken | 16 | AndToken | 17 | CommaToken | 18 | PeriodToken 19 | deriving (Show, Eq) 20 | 21 | tokenize :: String -> Either Parsec.ParseError [Token] 22 | tokenize sourceCode = 23 | Parsec.parse slFileParser "" sourceCode 24 | |> flattenTokenList 25 | 26 | slFileParser :: Parsec.Parsec String () [[Token]] 27 | slFileParser = Parsec.manyTill statementParser Parsec.eof 28 | 29 | statementParser = do 30 | Parsec.choice [ 31 | Parsec.try clauseParser, 32 | Parsec.try evaluationParser, 33 | Parsec.try ruleParser 34 | ] 35 | 36 | clauseParser = do 37 | tokens <- relationParser 38 | periodParser 39 | return (tokens ++ [PeriodToken]) 40 | 41 | evaluationParser = do 42 | Parsec.string "evaluate" 43 | Parsec.many1 Parsec.space 44 | relationTokens <- relationParser 45 | periodParser 46 | return ([EvalToken] ++ relationTokens ++ [PeriodToken]) 47 | 48 | ruleParser = do 49 | headRelationTokens <- relationParser 50 | Parsec.many1 Parsec.space 51 | Parsec.string "if" 52 | Parsec.many1 Parsec.space 53 | bodyTokens <- Parsec.sepBy relationParser andParser 54 | let bodyTokensWithAnds = (intersperse [AndToken] bodyTokens) >>= id 55 | periodParser 56 | return (headRelationTokens ++ [IfToken] ++ bodyTokensWithAnds ++ [PeriodToken]) 57 | 58 | relationParser = do 59 | relationName <- nameParser 60 | relationBody <- relationArgsParser 61 | return (relationName : relationBody) 62 | 63 | relationArgsParser = do 64 | Parsec.char '(' 65 | argTokens <- Parsec.sepBy literalOrVarParser commaParser 66 | Parsec.char ')' 67 | let argTokensWithCommas = intersperse CommaToken argTokens 68 | return ([ParenOpenToken] ++ argTokensWithCommas ++ [ParenCloseToken]) 69 | 70 | literalOrVarParser = do 71 | Parsec.choice [nameParser, varParser, intParser] 72 | 73 | nameParser = do 74 | firstChar <- Parsec.lower 75 | rest <- Parsec.many Parsec.alphaNum 76 | let name = firstChar : rest 77 | return (NameToken name) 78 | 79 | intParser = do 80 | digits <- Parsec.many1 Parsec.digit 81 | let int = read digits :: Int 82 | return (IntToken int) 83 | 84 | varParser = do 85 | firstChar <- Parsec.upper 86 | rest <- Parsec.many Parsec.alphaNum 87 | let var = firstChar : rest 88 | return (VarToken var) 89 | 90 | andParser = do 91 | Parsec.spaces 92 | Parsec.string "and" 93 | Parsec.spaces 94 | return AndToken 95 | 96 | commaParser = do 97 | Parsec.spaces 98 | Parsec.char ',' 99 | Parsec.spaces 100 | return CommaToken 101 | 102 | periodParser = do 103 | Parsec.spaces 104 | Parsec.char '.' 105 | Parsec.spaces 106 | return PeriodToken 107 | 108 | flattenTokenList :: Either Parsec.ParseError [[Token]] -> Either Parsec.ParseError [Token] 109 | flattenTokenList (Left err) = Left err 110 | flattenTokenList (Right tokens) = Right (tokens >>= id) 111 | -------------------------------------------------------------------------------- /src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib (compile) where 2 | 3 | import Lexer (Token, tokenize) 4 | import Parser (AST, parse) 5 | import Validator (validate) 6 | import Transformer (transform) 7 | import Writer (write) 8 | import qualified Text.Parsec as Parsec 9 | -- import Debug.Trace (trace) 10 | 11 | -- Comment the below to enable debugging 12 | trace :: String -> a -> a 13 | trace _ x = x 14 | 15 | (|>) = flip ($) 16 | 17 | compile :: String -> String 18 | compile s = 19 | tokenize s 20 | |> postTokenize 21 | 22 | postTokenize :: Either Parsec.ParseError [Token] -> String 23 | postTokenize (Left err) = "Error when compiling: " ++ show err 24 | postTokenize (Right tokens) = 25 | trace ("Lexer: " ++ show tokens ++ "\n") (parse tokens) 26 | |> postParse 27 | 28 | postParse :: Maybe [AST] -> String 29 | postParse Nothing = "Error when parsing." 30 | postParse (Just astList) = 31 | trace ("Parser: " ++ show astList ++ "\n") (validate astList) 32 | |> postValidate 33 | 34 | postValidate :: Either String [AST] -> String 35 | postValidate (Left err) = "Error when validating: " ++ show err 36 | postValidate (Right astList) = 37 | trace "Validated. \n" (transform astList) 38 | |> postTransform 39 | 40 | postTransform :: [AST] -> String 41 | postTransform astList = 42 | trace ("Transformer: " ++ show astList ++ "\n") (write astList) 43 | |> postWrite 44 | 45 | postWrite :: String -> String 46 | postWrite jsCode = trace ("Writer: " ++ jsCode) jsCode 47 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser ( 2 | AST(..), 3 | Term(..), 4 | Relation(..), 5 | parse) where 6 | 7 | import Lexer (tokenize, Token(..)) 8 | 9 | (|>) = flip ($) 10 | 11 | data AST = 12 | Evaluation Relation | 13 | Fact Relation | 14 | Rule Relation [Relation] 15 | deriving (Show, Eq) 16 | 17 | -- Relation includes a name and a list of literals or variables 18 | data Relation = 19 | Relation String [Term] 20 | deriving (Show, Eq) 21 | 22 | data Term = Variable String | Atom String | IntLiteral Int 23 | deriving (Show, Eq) 24 | 25 | parse :: [Token] -> Maybe [AST] 26 | parse tokens = 27 | case tokens of 28 | (EvalToken : _) -> parseEvaluation tokens 29 | (NameToken _ : _) -> parseFactOrRule tokens 30 | [] -> Just [] 31 | _ -> Nothing 32 | 33 | parseEvaluation :: [Token] -> Maybe [AST] 34 | parseEvaluation (EvalToken : tokens) = 35 | case parseRelation tokens of 36 | Just (relation, (PeriodToken : rest)) -> 37 | parse rest 38 | |> fmap (\restAst -> (Evaluation relation : restAst)) 39 | _ -> Nothing 40 | parseEvaluation _ = Nothing 41 | 42 | parseFactOrRule :: [Token] -> Maybe [AST] 43 | parseFactOrRule tokens = 44 | let 45 | relationAndRest = parseRelation tokens 46 | in 47 | case relationAndRest of 48 | Just (_, (PeriodToken : _)) -> parseFact relationAndRest 49 | Just (_, (IfToken : _)) -> parseRule relationAndRest 50 | _ -> Nothing 51 | 52 | parseFact :: Maybe (Relation, [Token]) -> Maybe [AST] 53 | parseFact (Just (relation, (PeriodToken : rest))) = 54 | parse rest 55 | |> fmap (\restAst -> (Fact relation : restAst)) 56 | parseFact _ = Nothing 57 | 58 | parseRule :: Maybe (Relation, [Token]) -> Maybe [AST] 59 | parseRule (Just (headRelation, (IfToken : rest))) = 60 | parseRuleBody rest [] 61 | >>= (\(relations, remaining) -> 62 | parse remaining 63 | |> fmap (\restAst -> (Rule headRelation relations) : restAst) 64 | ) 65 | parseRule _ = Nothing 66 | 67 | parseRuleBody :: 68 | [Token] -> -- input of tokens 69 | [Relation] -> -- accumulated relations as partial solution 70 | Maybe ([Relation], [Token]) -- solution and remaining tokens 71 | parseRuleBody tokens acc = 72 | case parseRelation tokens of 73 | Just (relation, (AndToken : rest)) -> parseRuleBody rest (acc ++ [relation]) 74 | Just (relation, (PeriodToken : rest)) -> Just ((acc ++ [relation]), rest) 75 | _ -> Nothing 76 | 77 | parseRelation :: 78 | [Token] -> -- original list of tokens, starting with a name 79 | Maybe (Relation, [Token]) -- solution and remaining tokens 80 | parseRelation (NameToken name : rest) = 81 | parseRelationArgs rest [] 82 | |> fmap (\(args, remaining) -> (Relation name args, remaining)) 83 | parseRelation _ = Nothing 84 | 85 | parseRelationArgs :: 86 | [Token] -> -- original list of tokens, starting with open paren 87 | [Term] -> -- accumulated arguments as partial solution 88 | Maybe ([Term], [Token]) -- solution and remaining tokens 89 | parseRelationArgs (token : rest) acc = 90 | case token of 91 | ParenOpenToken -> if length acc == 0 then parseRelationArgs rest [] else Nothing 92 | NameToken name -> parseRelationArgs rest (acc ++ [Atom name]) 93 | VarToken var -> parseRelationArgs rest (acc ++ [Variable var]) 94 | IntToken int -> parseRelationArgs rest (acc ++ [IntLiteral int]) 95 | CommaToken -> parseRelationArgs rest acc 96 | ParenCloseToken -> Just (acc, rest) 97 | _ -> Nothing 98 | parseRelationArgs _ _ = Nothing 99 | -------------------------------------------------------------------------------- /src/Transformer.hs: -------------------------------------------------------------------------------- 1 | module Transformer (transform) where 2 | 3 | import Parser (AST(..), Term(..), Relation(..)) 4 | import Data.List (sortBy) 5 | 6 | (|>) = flip ($) 7 | 8 | transform :: [AST] -> [AST] 9 | transform astList = 10 | astList 11 | |> placeEvaluationsLast 12 | 13 | evaluationsLast :: AST -> AST -> Ordering 14 | evaluationsLast (Evaluation _) (Evaluation _) = EQ 15 | evaluationsLast _ (Evaluation _) = LT 16 | evaluationsLast (Evaluation _) _ = GT 17 | evaluationsLast _ _ = EQ 18 | 19 | placeEvaluationsLast :: [AST] -> [AST] 20 | placeEvaluationsLast astList = sortBy evaluationsLast astList 21 | -------------------------------------------------------------------------------- /src/Validator.hs: -------------------------------------------------------------------------------- 1 | module Validator (validate) where 2 | 3 | import Parser (AST(..), Term(..), Relation(..)) 4 | import ASTUtils (isRule, isFact, groupByRelation, inferRelationArity, isVariable) 5 | import Data.Maybe (isJust) 6 | import qualified Data.List as List 7 | 8 | (|>) = flip ($) 9 | 10 | type ValidationError = String 11 | 12 | validate :: [AST] -> Either ValidationError [AST] 13 | validate astList = 14 | astList 15 | |> checkEach 16 | |> (=<<) checkOverall 17 | 18 | -- Checks whether each statement looks ok, in isolation. 19 | checkEach :: [AST] -> Either ValidationError [AST] 20 | checkEach astList = 21 | case foldl check Nothing astList of 22 | Nothing -> Right astList 23 | Just err -> Left err 24 | 25 | where 26 | check :: Maybe ValidationError -> AST -> Maybe ValidationError 27 | check prev ast = 28 | case prev of 29 | Just err -> Just err 30 | Nothing -> 31 | case ast of 32 | Evaluation _ -> checkEvaluation ast 33 | Fact _ -> checkFact ast 34 | Rule _ _ -> checkRule ast 35 | 36 | -- Checks whether an evaluation looks ok, in isolation. 37 | -- An evaluation should have at least one variable in the terms. 38 | checkEvaluation :: AST -> Maybe ValidationError 39 | checkEvaluation ast = 40 | case ast of 41 | Evaluation (Relation relationName terms) -> 42 | if (any isVariable terms) then 43 | Nothing 44 | else 45 | Just ("An evaluation should have at least one variable, check this out: " ++ show ast) 46 | _ -> Nothing 47 | 48 | -- Checks whether a fact looks ok, in isolation. 49 | -- Facts should have only constants, no variables. 50 | checkFact :: AST -> Maybe ValidationError 51 | checkFact ast = 52 | case ast of 53 | Fact (Relation relationName terms) -> 54 | if (all termIsConcrete terms) then 55 | Nothing 56 | else 57 | Just ("Fact should NOT have a variable, check this out: " ++ show ast) 58 | _ -> 59 | Just "This is weird, the validator got confused" 60 | 61 | where 62 | termIsConcrete :: Term -> Bool 63 | termIsConcrete term = 64 | case term of 65 | Atom _ -> True 66 | IntLiteral _ -> True 67 | Variable _ -> False 68 | 69 | -- Checks whether a rule looks ok, in isolation. 70 | checkRule :: AST -> Maybe ValidationError 71 | checkRule ast = 72 | case checkRuleOnlyHasVars ast of 73 | Just err -> Just err 74 | Nothing -> 75 | checkAllRuleHeadVarsInBody ast 76 | 77 | -- Checks whether the relations in a rule only contain variables. 78 | checkRuleOnlyHasVars :: AST -> Maybe ValidationError 79 | checkRuleOnlyHasVars ast = 80 | case ast of 81 | Rule relHead body -> 82 | if (relationOnlyHasVars relHead && all relationOnlyHasVars body) then 83 | Nothing 84 | else 85 | Just ("Rule should only have variables, check this out: " ++ show ast) 86 | 87 | where 88 | relationOnlyHasVars :: Relation -> Bool 89 | relationOnlyHasVars (Relation _ terms) = 90 | all isVariable terms 91 | 92 | -- Checks whether all head variables of a rule are in the body relations too. 93 | checkAllRuleHeadVarsInBody :: AST -> Maybe ValidationError 94 | checkAllRuleHeadVarsInBody ast = 95 | case ast of 96 | Rule (Relation headName headTerms) bodyRelations -> 97 | let 98 | passed = 99 | headTerms 100 | |> filter isVariable 101 | |> all (isVariableIn bodyRelations) 102 | in 103 | if passed then 104 | Nothing 105 | else 106 | Just ("Rule should include all head variables in the body, check this out: " ++ show ast) 107 | _ -> 108 | Just "This is weird, the validator got confused" 109 | 110 | where 111 | isVariableIn :: [Relation] -> Term -> Bool 112 | isVariableIn relations variable = 113 | any (\(Relation _ terms) -> elem variable terms) relations 114 | 115 | -- Checks whether the program looks ok cross-statements. 116 | checkOverall :: [AST] -> Either ValidationError [AST] 117 | checkOverall astList = 118 | astList 119 | |> checkEachRelationArity 120 | |> (=<<) checkEachRuleHasNoFacts 121 | |> (=<<) checkRelatedRulesHaveSameHead 122 | 123 | -- Checks whether all statements of a relation have the same arity. 124 | checkEachRelationArity :: [AST] -> Either ValidationError [AST] 125 | checkEachRelationArity astList = 126 | let 127 | errors = detectEachArityError astList 128 | errorReport = reportErrors errors 129 | in 130 | if any isJust errors then 131 | Left errorReport 132 | else 133 | Right astList 134 | 135 | where 136 | detectEachArityError :: [AST] -> [Maybe ValidationError] 137 | detectEachArityError astList = 138 | astList 139 | |> groupByRelation 140 | |> map detectArityError 141 | 142 | detectArityError :: (String, [AST]) -> Maybe ValidationError 143 | detectArityError relation = 144 | if isRelationArityConsistent relation then 145 | Nothing 146 | else 147 | Just ("Inconsistent arity for relation " ++ fst relation) 148 | 149 | isRelationArityConsistent :: (String, [AST]) -> Bool 150 | isRelationArityConsistent (_, astList) = 151 | astList 152 | |> map inferRelationArity 153 | |> foldl compareArity (-1, True) 154 | |> snd 155 | 156 | compareArity :: (Int, Bool) -> Int -> (Int, Bool) 157 | compareArity (_, False) x1 = (x1, False) 158 | compareArity (x0, True) x1 = 159 | let 160 | isEq = x0 == x1 161 | in 162 | if x0 == -1 then 163 | (x1, True) 164 | else 165 | (x1, isEq) 166 | 167 | reportErrors :: [Maybe ValidationError] -> ValidationError 168 | reportErrors errors = 169 | errors 170 | |> filter isJust 171 | |> map (\x -> case x of Just err -> err; Nothing -> "") 172 | |> foldl (++) "" 173 | 174 | -- Checks whether each rule is the only statement for that relation. 175 | checkEachRuleHasNoFacts :: [AST] -> Either ValidationError [AST] 176 | checkEachRuleHasNoFacts astList = 177 | let 178 | passed = 179 | astList 180 | |> filter isRule 181 | |> all (ruleHasNoFacts astList) 182 | in 183 | if passed then 184 | Right astList 185 | else 186 | Left "If there is a rule for a relation, there cannot be facts for that relation" 187 | 188 | where 189 | ruleHasNoFacts :: [AST] -> AST -> Bool 190 | ruleHasNoFacts astList (Rule (Relation relationName _) _) = 191 | astList 192 | |> filter isFact 193 | |> all (\fact -> not (isFactName relationName fact)) 194 | ruleHasNoFacts _ _ = False 195 | 196 | isFactName :: String -> AST -> Bool 197 | isFactName name (Fact (Relation factName _)) = name == factName 198 | isFactName _ _ = False 199 | 200 | -- Checks whether all rules of the same relation have the same head, 201 | -- with the same variable names and order. 202 | checkRelatedRulesHaveSameHead :: [AST] -> Either ValidationError [AST] 203 | checkRelatedRulesHaveSameHead astList = 204 | let 205 | passed = 206 | astList 207 | |> filter isRule 208 | |> groupByRelation 209 | |> all haveSameHead 210 | in 211 | if passed then 212 | Right astList 213 | else 214 | Left "All rules for the same relation should have the same type of head" 215 | 216 | where 217 | haveSameHead :: (String, [AST]) -> Bool 218 | haveSameHead (_, rules) = 219 | rules 220 | |> map statementHead 221 | |> List.nub 222 | |> (\list -> length list == 1) 223 | 224 | statementHead :: AST -> Relation 225 | statementHead (Rule ruleHead _) = ruleHead 226 | statementHead (Fact rel) = rel 227 | statementHead (Evaluation rel) = rel -------------------------------------------------------------------------------- /src/Writer.hs: -------------------------------------------------------------------------------- 1 | module Writer (write) where 2 | 3 | import Parser (AST(..), Term(..), Relation(..)) 4 | import ASTUtils (isRule, isFact, isEvaluation, groupByRelation, inferRelationArity, isVariable) 5 | import qualified Data.Map as Map 6 | import Data.List (uncons, intersperse, nub, (\\)) 7 | import qualified Debug.Trace as Debug 8 | 9 | (|>) = flip ($) 10 | 11 | write :: [AST] -> String 12 | write astList = 13 | let 14 | (facts, rules, evaluations) = classify astList 15 | factsBlock = writeAllFacts facts 16 | rulesBlock = writeAllRules rules 17 | varsBlock = writeEvaluationVariables evaluations 18 | evalsBlock = writeAllEvaluations evaluations 19 | in 20 | header ++ 21 | "\n" ++ 22 | factsBlock ++ 23 | "\n" ++ 24 | rulesBlock ++ 25 | "\n" ++ 26 | varsBlock ++ 27 | evalsBlock 28 | 29 | header :: String 30 | header = 31 | "var $logic = require('logicjs');\n" ++ 32 | "var $or = $logic.or, $and = $logic.and, $eq = $logic.eq, $lvar = $logic.lvar;\n" ++ 33 | "function $report(t, vns, vss){" ++ 34 | "console.log('evaluate '+t+':\\n'+" ++ 35 | "vss.map(function(vs,j){" ++ 36 | "return' '+(j+1)+'. '+vs.map(function(v,i){" ++ 37 | "return vns[i]+'='+v;" ++ 38 | "}).join(', ');" ++ 39 | "}).join('\\n')" ++ 40 | ");" ++ 41 | "}\n" 42 | 43 | classify :: [AST] -> ([AST], [AST], [AST]) 44 | classify astList = 45 | let 46 | facts = filter isFact astList 47 | rules = filter isRule astList 48 | evaluations = filter isEvaluation astList 49 | in 50 | (facts, rules, evaluations) 51 | 52 | writeAllFacts :: [AST] -> String 53 | writeAllFacts facts = 54 | facts 55 | |> reverse 56 | |> groupByRelation 57 | |> map writeFactGroup 58 | |> intersperse "\n" 59 | |> join 60 | 61 | where 62 | writeFactGroup :: (String, [AST]) -> String 63 | writeFactGroup (name, facts) = 64 | let 65 | factsWritten = facts |> map writeFact 66 | in 67 | "function " ++ name ++ "(" ++ (makeFactGroupArguments facts) ++ ") {\n" ++ 68 | (if length facts == 1 then 69 | " return " ++ (factsWritten |> join) ++ ";\n" 70 | else 71 | " return $or(\n" ++ 72 | " " ++ (factsWritten |> intersperse ",\n " |> join) ++ "\n" ++ 73 | " );\n" 74 | ) ++ 75 | "}\n" 76 | 77 | writeFact :: AST -> String 78 | writeFact ast = 79 | case ast of 80 | Fact (Relation _ terms) -> 81 | case uncons terms of 82 | Just (term, []) -> 83 | writeFactTermEquation("X1", term) 84 | Just (_, _) -> 85 | "$and(" ++ 86 | (ast 87 | |> inferRelationArity 88 | |> makeVariables 89 | |> zip terms 90 | |> map (\(x,y) -> (y,x)) 91 | |> map writeFactTermEquation 92 | |> intersperse ", " 93 | |> join) ++ 94 | ")" 95 | Nothing -> 96 | "IMPOSSIBLE" 97 | _ -> 98 | "IMPOSSIBLE" 99 | 100 | writeFactTermEquation :: (String, Term) -> String 101 | writeFactTermEquation (var, term) = 102 | "$eq(" ++ var ++ ", " ++ (writeFactTerm term) ++ ")" 103 | 104 | writeFactTerm :: Term -> String 105 | writeFactTerm (Atom str) = "'" ++ str ++ "'" 106 | writeFactTerm (IntLiteral int) = show int 107 | writeFactTerm (Variable _) = "IMPOSSIBLE" 108 | 109 | makeFactGroupArguments :: [AST] -> String 110 | makeFactGroupArguments astList = 111 | astList 112 | |> inferArity 113 | |> makeVariables 114 | |> intersperse ", " 115 | |> join 116 | 117 | inferArity :: [AST] -> Int 118 | inferArity astList = 119 | case uncons astList of 120 | Just (ast, _) -> inferRelationArity ast 121 | Nothing -> 0 122 | 123 | makeVariables :: Int -> [String] 124 | makeVariables arity = 125 | [1..arity] 126 | |> map (\x -> "X" ++ show x) 127 | 128 | writeAllRules :: [AST] -> String 129 | writeAllRules rules = 130 | rules 131 | |> reverse 132 | |> groupByRelation 133 | |> map writeRuleGroup 134 | |> intersperse "\n" 135 | |> join 136 | 137 | where 138 | writeRuleGroup :: (String, [AST]) -> String 139 | writeRuleGroup (name, rules) = 140 | let 141 | args = makeRuleGroupArgs rules 142 | dummyVars = getDummyVars rules 143 | rulesWritten = rules |> map writeRule 144 | in 145 | "function " ++ name ++ "(" ++ args ++ ") {\n" ++ 146 | (dummyVars |> map (\var -> 147 | " var " ++ (writeVar var) ++ " = $lvar();\n") |> join) ++ 148 | (if length rules == 1 then 149 | " return " ++ (rulesWritten |> join) ++ ";\n" 150 | else 151 | " return $or(\n" ++ 152 | " " ++ (rulesWritten |> intersperse ",\n " |> join) ++ "\n" ++ 153 | " );\n" 154 | ) ++ 155 | "}\n" 156 | 157 | writeRule :: AST -> String 158 | writeRule (Rule (Relation name headVars) body) = 159 | let 160 | bodyRelationsWritten = body |> map writeBodyRelation 161 | in 162 | (if length body == 1 then 163 | (bodyRelationsWritten |> join) 164 | else 165 | "$and(" ++ (bodyRelationsWritten |> intersperse ", " |> join) ++ ")" 166 | ) 167 | writeRule _ = "IMPOSSIBLE" 168 | 169 | getDummyVars :: [AST] -> [Term] 170 | getDummyVars rules = 171 | let 172 | headVars = getHeadVars rules 173 | bodyVars = rules |> map getBodyVars |> flatten |> nub 174 | in 175 | bodyVars \\ headVars 176 | 177 | getHeadVars :: [AST] -> [Term] 178 | getHeadVars rules = 179 | case uncons rules of 180 | Just (Rule (Relation _ headVars) _, _) -> headVars 181 | _ -> [] 182 | 183 | getBodyVars :: AST -> [Term] 184 | getBodyVars (Rule _ body) = 185 | body 186 | |> map (\(Relation _ terms) -> terms) 187 | |> flatten 188 | |> nub 189 | getBodyVars _ = [] 190 | 191 | makeRuleGroupArgs :: [AST] -> String 192 | makeRuleGroupArgs rules = 193 | case uncons rules of 194 | Just (Rule (Relation _ headVars) _, rest) -> makeRuleArgs headVars 195 | _ -> "" 196 | 197 | makeRuleArgs :: [Term] -> String 198 | makeRuleArgs terms = 199 | terms 200 | |> map writeVar 201 | |> intersperse ", " 202 | |> join 203 | 204 | writeVar :: Term -> String 205 | writeVar (Variable x) = x 206 | writeVar _ = "IMPOSSIBLE" 207 | 208 | writeBodyRelation :: Relation -> String 209 | writeBodyRelation (Relation name vars) = 210 | name ++ "(" ++ (vars |> map writeVar |> intersperse ", " |> join) ++ ")" 211 | 212 | writeEvaluationVariables :: [AST] -> String 213 | writeEvaluationVariables evaluations = 214 | evaluations 215 | |> map extractEvaluationVariables 216 | |> flatten 217 | |> nub 218 | |> map writeVar 219 | |> intersperse "\n" 220 | |> join 221 | 222 | where 223 | extractEvaluationVariables :: AST -> [Term] 224 | extractEvaluationVariables ast = 225 | case ast of 226 | (Evaluation (Relation _ terms)) -> 227 | terms |> filter isVariable 228 | _ -> 229 | [] 230 | 231 | writeVar :: Term -> String 232 | writeVar (Variable v) = "var " ++ v ++ " = $lvar();\n" 233 | writeVar _ = "IMPOSSIBLE" 234 | 235 | writeAllEvaluations :: [AST] -> String 236 | writeAllEvaluations evaluations = 237 | evaluations 238 | |> map writeEvaluation 239 | |> join 240 | 241 | where 242 | writeEvaluation :: AST -> String 243 | writeEvaluation (Evaluation (Relation name terms)) = 244 | let 245 | args = terms |> map writeTerm |> intersperse "," |> join 246 | vars = terms |> filter isVariable |> map writeTerm 247 | varsAsStrings = vars |> map wrapWithQuotes |> intersperse "," |> join 248 | rawVars = vars |> intersperse "," |> join 249 | title = writeReportTitle (Relation name terms) 250 | in 251 | "$report(" ++ 252 | title ++ ", " ++ 253 | "[" ++ varsAsStrings ++ "], " ++ 254 | "$logic.run(" ++ name ++ "(" ++ args ++ "), [" ++ rawVars ++ "])" ++ 255 | ");\n" 256 | writeEvaluation _ = "IMPOSSIBLE" 257 | 258 | writeTerm :: Term -> String 259 | writeTerm (Atom str) = "'" ++ str ++ "'" 260 | writeTerm (IntLiteral int) = show int 261 | writeTerm (Variable var) = var 262 | 263 | writeReportTitle :: Relation -> String 264 | writeReportTitle (Relation name terms) = 265 | "'" ++ name ++ "(" ++ (terms |> map (\term -> 266 | case term of 267 | Atom str -> str 268 | IntLiteral int -> show int 269 | Variable var -> var 270 | ) |> intersperse "," |> join) ++ 271 | ")'" 272 | 273 | wrapWithQuotes :: String -> String 274 | wrapWithQuotes x = "'" ++ x ++ "'" 275 | 276 | flatten :: [[a]] -> [a] 277 | flatten list = list >>= id 278 | 279 | join :: [String] -> String 280 | join = foldl (++) "" -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-7.14 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.2" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | --------------------------------------------------------------------------------