some small stuff

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 []

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

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

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

prlg.cabal

@@ -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: