diff options
| -rw-r--r-- | app/Compiler.hs | 54 | ||||
| -rw-r--r-- | app/Interpreter.hs | 16 | ||||
| -rw-r--r-- | app/Main.hs | 21 | ||||
| -rw-r--r-- | app/Parser.hs | 73 | ||||
| -rw-r--r-- | prlg.cabal | 2 |
5 files changed, 155 insertions, 11 deletions
diff --git a/app/Compiler.hs b/app/Compiler.hs new file mode 100644 index 0000000..7684f80 --- /dev/null +++ b/app/Compiler.hs @@ -0,0 +1,54 @@ +module Compiler where + +import Data.List +import Interpreter (Code, Datum(..), Id(..), Instr(..), StrTable, strtablize) + +data PrlgStr + = CallS String [PrlgStr] + | LiteralS String + deriving (Show) + +data PrlgInt + = CallI Id [PrlgInt] + | LiteralI Int --split off vars here later + deriving (Show) + +strtablizePrlg :: StrTable -> PrlgStr -> (StrTable, PrlgInt) +strtablizePrlg = go + where + go t (LiteralS str) = LiteralI <$> strtablize t str + go t (CallS str ps) = + let (t', i) = strtablize t str + in CallI (Id i $ length ps) <$> mapAccumL go t' ps + +compileGoals :: Id -> PrlgInt -> [Code] +compileGoals andop = go + where + go p@(CallI x args) + | x == andop = concatMap go args + go x = [compileGoal x] + +compileGoal :: PrlgInt -> Code +compileGoal (LiteralI x) = [U (Struct $ Id x 0)] +compileGoal x = compileArg x + +compileArg :: PrlgInt -> Code +compileArg (CallI x args) = U (Struct x) : concatMap compileArg args +compileArg (LiteralI x) = [U (Atom x)] + +seqGoals :: [Code] -> Code +seqGoals [] = [NoGoal] +seqGoals [[Cut]] = [Cut, NoGoal] +seqGoals [x] = [Goal] ++ x ++ [LastCall] +seqGoals [x, [Cut]] = [Goal] ++ x ++ [LastCall, Cut] +seqGoals (x:xs) = [Goal] ++ x ++ [Call] ++ seqGoals xs + +compileRule :: Id -> Id -> PrlgInt -> Code +compileRule proveop andop = go + where + go :: PrlgInt -> Code + go h@(CallI x args) + | x == proveop + , [head, goals] <- args = + compileGoal head ++ seqGoals (compileGoals andop goals) + | otherwise = compileGoal h ++ seqGoals [] diff --git a/app/Interpreter.hs b/app/Interpreter.hs index 81ecb3d..7df773e 100644 --- a/app/Interpreter.hs +++ b/app/Interpreter.hs @@ -5,11 +5,21 @@ import qualified Data.Map as M {- VAM 2P, done the lazy way -} data StrTable = - StrTable Int (M.Map Int String) + StrTable Int (M.Map String Int) (M.Map Int String) + deriving Show + +emptystrtable = StrTable 0 M.empty M.empty + +strtablize t@(StrTable nxt fwd rev) str = + case fwd M.!? str of + Just i -> (t, i) + _ -> (StrTable (nxt + 1) (M.insert str nxt fwd) (M.insert nxt str rev), nxt) + +data Id = Id {str::Int,arity::Int} deriving (Show, Eq, Ord) data Datum = Atom Int -- unifies a constant - | Struct (Int, Int) -- unifies a structure with arity + | Struct Id -- unifies a structure with arity -- | VoidVar -- unifies with anything -- | LocalVar Int -- unifies with a local variable (possibly making a new one when it's not in use yet) -- | Ref Int -- unifies with the referenced value on the heap (not to be used in code) @@ -26,7 +36,7 @@ data Instr type Code = [Instr] -type Defs = M.Map (Int, Int) [Code] +type Defs = M.Map Id [Code] data Cho = Cho diff --git a/app/Main.hs b/app/Main.hs index c2f03ee..0a1ba8f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,32 +1,39 @@ module Main where +import qualified Data.Map as M import Interpreter import Text.Pretty.Simple -import qualified Data.Map as M ppr :: Show a => a -> IO () -ppr = pPrintOpt CheckColorTty defaultOutputOptionsDarkBg {outputOptionsCompactParens = True, outputOptionsIndentAmount = 2, outputOptionsPageWidth=80} +ppr = + pPrintOpt + CheckColorTty + defaultOutputOptionsDarkBg + { outputOptionsCompactParens = True + , outputOptionsIndentAmount = 2 + , outputOptionsPageWidth = 80 + } main :: IO () main = do let (res, interp) = - prove [Goal, U (Struct (1, 2)), U (Atom 1), U (Atom 2), LastCall] $ + prove [Goal, U (Struct $ Id 1 2), U (Atom 1), U (Atom 2), LastCall] $ M.fromList - [ ( (1, 2) + [ ( Id 1 2 , [ [U (Atom 333), U (Atom 444), NoGoal] , [ U (Atom 1) , U (Atom 2) , Goal - , U (Struct (2, 0)) + , U (Struct $ Id 2 0) , Call , Goal - , U (Struct (5, 2)) + , U (Struct $ Id 1 2) , U (Atom 333) , U (Atom 444) , LastCall ] ]) - , ((2, 0), [[NoGoal]]) + , (Id 2 0, [[NoGoal]]) ] ppr interp ppr res diff --git a/app/Parser.hs b/app/Parser.hs new file mode 100644 index 0000000..d43dce2 --- /dev/null +++ b/app/Parser.hs @@ -0,0 +1,73 @@ +module Parser where + +import Control.Applicative (liftA2) +import Data.Char +import Data.Void +import Text.Megaparsec +import Text.Megaparsec.Char + +data AST + = Call String [AST] + | Seq [AST] + | List [AST] (Maybe AST) + | Literal String + deriving (Show) + +specialOp = (`elem` ",;|") + +specialChar = (`elem` "()[]") + +specialName = (`elem` "_") + +specialUnused = (`elem` "\'%") + +type Lexer = Parsec Void String + +data Lexeme + = Blank String + | Tok String + | QTok String String -- unquoted quoted + | Cmt String + deriving (Show) + +blank :: Lexer Lexeme +blank = Blank <$> some (satisfy isSpace) + +tok :: Lexer Lexeme +tok = + Tok <$> + choice + [ pure <$> satisfy specialOp + , pure <$> satisfy specialChar + , some $ + satisfy $ \x -> + all + ($ x) + [ not . specialOp + , not . specialChar + , not . specialUnused + , not . specialName + , liftA2 (||) isSymbol isPunctuation + ] + , (:) <$> satisfy (\x -> any ($ x) [specialName, isAlpha]) <*> + many (satisfy $ \x -> any ($ x) [specialName, isAlphaNum, isMark]) + ] + +qtok :: Lexer Lexeme +qtok = do + x <- string "'" + y <- many $ satisfy (/= '\'') + z <- string "'" + return $ QTok y (x ++ y ++ z) + +cmt :: Lexer Lexeme +cmt = + Cmt . concat <$> + sequence + [string "%", many $ satisfy (/= '\n'), choice [string "\n", "" <$ eof]] + +lexeme :: Lexer Lexeme +lexeme = choice [blank, tok, qtok, cmt] + +lex :: Lexer [Lexeme] +lex = many lexeme <* eof @@ -25,7 +25,7 @@ executable prlg main-is: Main.hs -- Modules included in this executable, other than Main. - other-modules: Interpreter + other-modules: Interpreter, Compiler, Parser -- LANGUAGE extensions used by modules in this package. -- other-extensions: |