exa/prlg
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: exa:17138aabda12645b6dc7f61f080997700738c461
Branches Tags
exa:master
..
compare: exa:336feaeba099086eec2a7853b3b3e9fc9a822c64
Branches Tags
exa:master

No commits in common. "17138aabda12645b6dc7f61f080997700738c461" and "336feaeba099086eec2a7853b3b3e9fc9a822c64" have entirely different histories.
17138aabda ... 336feaeba0

13 changed files with 264 additions and 368 deletions
Show stats Expand all files Collapse all files

253
app/Builtins.hs
View file

@ -2,10 +2,9 @@ module Builtins where
import Paths_prlg import Paths_prlg
import Code (Builtin(..), Code, Datum(..), Id(..), Instr(..), InterpFn) import Code (Builtin(..), Code, Datum(..), Instr(..), InterpFn)
import CodeLens import CodeLens
import qualified Compiler as Co import qualified Compiler as Co
import Constant
import Control.Exception (IOException, catch) import Control.Exception (IOException, catch)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
@ -17,7 +16,7 @@ import qualified Data.Map as M
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Env (PrlgEnv(..), findAtom, findStruct, prlgError) import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
import Heap (Dereferenced(..), derefHeap, heapStruct, newHeapVars, writeHeap) import Heap (Dereferenced(..), derefHeap, heapStruct, newHeapVars, writeHeap)
import IR (PrlgInt(..), StrTable(..)) import qualified IR
import Interpreter (backtrack) import Interpreter (backtrack)
import Lens.Micro.Mtl import Lens.Micro.Mtl
import Load (processInput) import Load (processInput)
@ -30,11 +29,10 @@ continue = pure Nothing
showTerm itos heap = runIdentity . heapStruct atom struct hrec heap showTerm itos heap = runIdentity . heapStruct atom struct hrec heap
where where
atom (C (Atom a)) = pure $ "'" ++ itos M.! a ++ "'" atom (Atom a) = pure $ "'" ++ itos M.! a ++ "'"
atom (C (Number n)) = pure (show n) atom (Number n) = pure (show n)
atom (C (Str str)) = pure (show str)
atom VoidRef = pure "_" atom VoidRef = pure "_"
struct (Struct (Id h _)) args = struct (Struct (IR.Id h _)) args =
pure $ "'" ++ itos M.! h ++ "'(" ++ intercalate "," args ++ ")" pure $ "'" ++ itos M.! h ++ "'(" ++ intercalate "," args ++ ")"
hrec (HeapRef hr) ref = hrec (HeapRef hr) ref =
pure $ pure $
@ -47,7 +45,7 @@ printLocals :: InterpFn
printLocals = do printLocals = do
scope <- use (cur . gvar) scope <- use (cur . gvar)
heap <- use (cur . heap) heap <- use (cur . heap)
StrTable _ _ itos <- use strtable IR.StrTable _ _ itos <- use strtable
flip traverse (M.assocs scope) $ \(local, ref) -> flip traverse (M.assocs scope) $ \(local, ref) ->
lift . outputStrLn $ "_Local" ++ show local ++ " = " ++ lift . outputStrLn $ "_Local" ++ show local ++ " = " ++
showTerm itos heap ref showTerm itos heap ref
@ -78,7 +76,7 @@ write' :: InterpFn -> InterpFn
write' c = write' c =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
StrTable _ _ itos <- use strtable IR.StrTable _ _ itos <- use strtable
lift . outputStr $ showTerm itos heap arg lift . outputStr $ showTerm itos heap arg
c --this now allows error fallthrough but we might like EitherT c --this now allows error fallthrough but we might like EitherT
@ -92,31 +90,32 @@ nl = do
writeln :: InterpFn writeln :: InterpFn
writeln = write' nl writeln = write' nl
assertFact :: (Code -> Id -> PrlgEnv ()) -> InterpFn assertFact :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
assertFact addClause = assertFact addClause =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
case Co.heapStructPrlgInt Nothing heap arg of case Co.compileGoal . Co.squashVars <$>
Just x -> do Co.heapStructPrlgInt Nothing heap arg of
case Co.compileGoal $ Co.squashVars x of Just (U (Struct s):head) -> do
Right (U (Struct s):head) -> do addClause (head ++ [Done]) s
addClause (head ++ [Done]) s continue
continue
Left err -> prlgError err
_ -> prlgError "assert fact failure" _ -> prlgError "assert fact failure"
assertRule :: (Code -> Id -> PrlgEnv ()) -> InterpFn assertRule :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
assertRule addClause = assertRule addClause =
withArgs [0, 1] $ \args -> do withArgs [0, 1] $ \args -> do
scope <- use (cur . hvar) scope <- use (cur . hvar)
heap <- use (cur . heap) heap <- use (cur . heap)
[comma, semi, cut] <- traverse findAtom [",", ";", "!"] comma <- findAtom ","
semi <- findAtom ";"
cut <- findAtom "!"
case Co.squashVars . IR.CallI 0 <$> case Co.squashVars . IR.CallI 0 <$>
traverse (Co.heapStructPrlgInt Nothing heap) args of traverse (Co.heapStructPrlgInt Nothing heap) args of
Just (IR.CallI 0 [hs, gs]) -> Just (IR.CallI 0 [hs, gs]) ->
case (++) <$> Co.compileGoal hs <*> Co.compileGoals comma semi cut gs of let (U (Struct s):cs) =
Right (U (Struct s):cs) -> addClause cs s >> continue Co.compileGoal hs ++ Co.compileGoals comma semi cut gs
Left err -> prlgError err in do addClause cs s
continue
_ -> prlgError "assert clause failure" _ -> prlgError "assert clause failure"
retractall :: InterpFn retractall :: InterpFn
@ -124,29 +123,37 @@ retractall =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
case derefHeap heap arg of case derefHeap heap arg of
BoundRef _ (C (Atom a)) -> BoundRef _ (Atom a) ->
dropProcedure (Id {arity = 0, str = a}) >> continue dropProcedure (IR.Id {IR.arity = 0, IR.str = a}) >> continue
BoundRef _ (Struct id) -> dropProcedure id >> continue BoundRef _ (Struct id) -> dropProcedure id >> continue
_ -> prlgError "retractall needs a struct" _ -> prlgError "retractall needs a struct"
call :: InterpFn exec' :: (Code -> Code) -> InterpFn
call = exec' fgol =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
case derefHeap heap arg of case Co.squashVars <$> Co.heapStructPrlgInt Nothing heap arg of
BoundRef _ (C (Atom a)) -> do Just gs -> do
cur . hed .= [U (Struct (Id {str = a, arity = 0})), Done] comma <- findAtom ","
semi <- findAtom ";"
cut <- findAtom "!"
zoom cur $ do
hvar .= M.empty
hed .= Co.compileGoals comma semi cut gs
gol %= fgol
continue continue
BoundRef addr s@(Struct Id {arity = arity}) -> do _ -> prlgError "bad goal"
cur . hed .= [U s] ++ [U (HeapRef $ addr + i) | i <- [1 .. arity]] ++
[Done] call :: InterpFn
continue call = exec' id
_ -> prlgError "bad call"
exec :: InterpFn
exec = exec' (const [Done])
stop :: InterpFn stop :: InterpFn
stop = stop =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
StrTable _ _ itos <- use strtable IR.StrTable _ _ itos <- use strtable
heap <- use (cur . heap) heap <- use (cur . heap)
prlgError $ "stop: " ++ showTerm itos heap arg prlgError $ "stop: " ++ showTerm itos heap arg
@ -156,18 +163,17 @@ struct = do
heap <- use (cur . heap) heap <- use (cur . heap)
scope <- use (cur . hvar) scope <- use (cur . hvar)
case derefHeap heap <$> scope M.!? 0 of case derefHeap heap <$> scope M.!? 0 of
Just (BoundRef _ (Struct Id {arity = arity, str = str})) -> Just (BoundRef addr (Struct IR.Id {IR.arity = arity, IR.str = str})) ->
structUnify arity str structUnify arity str
Just (BoundRef _ _) -> backtrack
_ -> structAssemble _ -> structAssemble
heapListLength listAtom heap ref = go 0 ref ref (id, fromJust . step) heapListLength listAtom heap ref = go 0 ref ref (id, fromJust . step)
where where
nil r nil r
| BoundRef _ str <- derefHeap heap r = str == C (Atom listAtom) | BoundRef _ str <- derefHeap heap r = str == Atom listAtom
| otherwise = False | otherwise = False
step r step r
| BoundRef addr (Struct Id {arity = 2, str = listAtom'}) <- | BoundRef addr (Struct IR.Id {IR.arity = 2, IR.str = listAtom'}) <-
derefHeap heap r derefHeap heap r
, listAtom == listAtom' = Just (addr + 2) , listAtom == listAtom' = Just (addr + 2)
| otherwise = Nothing | otherwise = Nothing
@ -184,7 +190,7 @@ structAssemble = do
heap <- use (cur . heap) heap <- use (cur . heap)
scope <- use (cur . hvar) scope <- use (cur . hvar)
case derefHeap heap <$> scope M.!? 1 of case derefHeap heap <$> scope M.!? 1 of
Just (BoundRef addr (C (Atom str))) -> do Just (BoundRef addr (Atom str)) -> do
listAtom <- findAtom "[]" listAtom <- findAtom "[]"
case scope M.!? 2 >>= heapListLength listAtom heap of case scope M.!? 2 >>= heapListLength listAtom heap of
Just arity -> structUnify arity str Just arity -> structUnify arity str
@ -197,17 +203,17 @@ structUnify arity str = do
listAtom <- findAtom "[]" listAtom <- findAtom "[]"
pvars <- newHeapVars arity pvars <- newHeapVars arity
let hcode = map U $ maybe VoidRef HeapRef . (scope M.!?) <$> [0 .. 2] let hcode = map U $ maybe VoidRef HeapRef . (scope M.!?) <$> [0 .. 2]
structData = Struct Id {arity = arity, str = str} : map HeapRef pvars structData =
Struct IR.Id {IR.arity = arity, IR.str = str} : map HeapRef pvars
paramsData = paramsData =
concatMap concatMap
(\pv -> [Struct Id {arity = 2, str = listAtom}, HeapRef pv]) (\pv -> [Struct IR.Id {IR.arity = 2, IR.str = listAtom}, HeapRef pv])
pvars ++ pvars ++
[C $ Atom listAtom] [Atom listAtom]
gcode = map U $ structData ++ [C $ Atom str] ++ paramsData gcode = map U $ structData ++ [Atom str] ++ paramsData
zoom cur $ do zoom cur $ do
gol %= (gcode ++) gol %= (gcode ++)
hed %= (hcode ++) hed %= (hcode ++)
unis += 3
continue continue
{- terms -} {- terms -}
@ -220,29 +226,12 @@ var = do
Just (FreeRef _) -> continue Just (FreeRef _) -> continue
_ -> backtrack _ -> backtrack
atom :: InterpFn
atom = do
heap <- use (cur . heap)
scope <- use (cur . hvar)
case derefHeap heap <$> scope M.!? 0 of
Just (BoundRef _ (C (Atom _))) -> continue
_ -> backtrack
number :: InterpFn number :: InterpFn
number = do number = do
heap <- use (cur . heap) heap <- use (cur . heap)
scope <- use (cur . hvar) scope <- use (cur . hvar)
case derefHeap heap <$> scope M.!? 0 of case derefHeap heap <$> scope M.!? 0 of
Just (BoundRef _ (C (Number _))) -> continue Just (BoundRef _ (Number _)) -> continue
_ -> backtrack
string :: InterpFn
string = do
heap <- use (cur . heap)
scope <- use (cur . hvar)
--TODO unify with number/var/...
case derefHeap heap <$> scope M.!? 0 of
Just (BoundRef _ (C (Str _))) -> continue
_ -> backtrack _ -> backtrack
sameTerm :: InterpFn sameTerm :: InterpFn
@ -271,9 +260,9 @@ op :: InterpFn
op = op =
withArgs [0, 1, 2] $ \args -> do withArgs [0, 1, 2] $ \args -> do
heap <- use (cur . heap) heap <- use (cur . heap)
StrTable _ _ itos <- use strtable IR.StrTable _ _ itos <- use strtable
case map (derefHeap heap) args of case map (derefHeap heap) args of
[BoundRef _ (C (Number prio)), BoundRef _ (C (Atom fixityAtom)), BoundRef _ (C (Atom opatom))] [BoundRef _ (Number prio), BoundRef _ (Atom fixityAtom), BoundRef _ (Atom opatom)]
| Just op <- | Just op <-
(,) <$> itos M.!? opatom <*> (,) <$> itos M.!? opatom <*>
(O.Op prio <$> ((itos M.!? fixityAtom) >>= O.fixity)) -> do (O.Op prio <$> ((itos M.!? fixityAtom) >>= O.fixity)) -> do
@ -285,9 +274,9 @@ deop :: InterpFn
deop = deop =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
StrTable _ _ itos <- use strtable IR.StrTable _ _ itos <- use strtable
case derefHeap heap arg of case derefHeap heap arg of
BoundRef _ (C (Atom opatom)) BoundRef _ (Atom opatom)
| Just op <- itos M.!? opatom -> do | Just op <- itos M.!? opatom -> do
ops %= filter ((/= op) . fst) ops %= filter ((/= op) . fst)
continue continue
@ -337,8 +326,7 @@ intBinary op =
withArgs [0, 1] $ \[arg1, arg2] -> do withArgs [0, 1] $ \[arg1, arg2] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
case derefHeap heap <$> [arg1, arg2] of case derefHeap heap <$> [arg1, arg2] of
[BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] -> [BoundRef _ (Number n1), BoundRef _ (Number n2)] -> putInt (op n1 n2) 2
putInt (op n1 n2) 2
_ -> prlgError "int binary needs numbers" _ -> prlgError "int binary needs numbers"
intBinPred :: (Int -> Int -> Bool) -> InterpFn intBinPred :: (Int -> Int -> Bool) -> InterpFn
@ -346,7 +334,7 @@ intBinPred op =
withArgs [0, 1] $ \args -> do withArgs [0, 1] $ \args -> do
heap <- use (cur . heap) heap <- use (cur . heap)
case derefHeap heap <$> args of case derefHeap heap <$> args of
[BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] -> [BoundRef _ (Number n1), BoundRef _ (Number n2)] ->
if op n1 n2 if op n1 n2
then continue then continue
else backtrack else backtrack
@ -357,7 +345,7 @@ intUnary op =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
case derefHeap heap arg of case derefHeap heap arg of
BoundRef _ (C (Number n)) -> putInt (op n) 1 BoundRef _ (Number n) -> putInt (op n) 1
_ -> prlgError "int unary needs number" _ -> prlgError "int unary needs number"
intUnPred :: (Int -> Bool) -> InterpFn intUnPred :: (Int -> Bool) -> InterpFn
@ -365,7 +353,7 @@ intUnPred op =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
case derefHeap heap arg of case derefHeap heap arg of
BoundRef _ (C (Number n)) -> BoundRef _ (Number n) ->
if op n if op n
then continue then continue
else backtrack else backtrack
@ -378,28 +366,28 @@ putInt val sc = do
Nothing -> continue Nothing -> continue
Just a -> Just a ->
case derefHeap heap a of case derefHeap heap a of
BoundRef _ (C (Number val')) BoundRef _ (Number val')
| val == val' -> continue | val == val' -> continue
FreeRef a' -> writeHeap a' (C (Number val)) >> continue FreeRef a' -> writeHeap a' (Number val) >> continue
_ -> backtrack _ -> backtrack
{- adding the builtins -} {- adding the builtins -}
addOp :: (String, O.Op) -> PrlgEnv () addOp :: (String, O.Op) -> PrlgEnv ()
addOp op = ops %= (op :) addOp op = ops %= (op :)
modDef :: ([Code] -> Maybe [Code]) -> Id -> PrlgEnv () modDef :: ([Code] -> Maybe [Code]) -> IR.Id -> PrlgEnv ()
modDef fn struct = defs %= M.alter (maybe (fn []) fn) struct modDef fn struct = defs %= M.alter (maybe (fn []) fn) struct
addClauseA :: Code -> Id -> PrlgEnv () addClauseA :: Code -> IR.Id -> PrlgEnv ()
addClauseA code = modDef $ Just . (code :) addClauseA code = modDef $ Just . (code :)
addClauseZ :: Code -> Id -> PrlgEnv () addClauseZ :: Code -> IR.Id -> PrlgEnv ()
addClauseZ code = modDef $ Just . (++ [code]) addClauseZ code = modDef $ Just . (++ [code])
addProcedure :: [Code] -> Id -> PrlgEnv () addProcedure :: [Code] -> IR.Id -> PrlgEnv ()
addProcedure heads = modDef $ Just . const heads addProcedure heads = modDef $ Just . const heads
dropProcedure :: Id -> PrlgEnv () dropProcedure :: IR.Id -> PrlgEnv ()
dropProcedure = modDef $ const Nothing dropProcedure = modDef $ const Nothing
addProc :: [Code] -> String -> Int -> PrlgEnv () addProc :: [Code] -> String -> Int -> PrlgEnv ()
@ -425,9 +413,9 @@ load :: Bool -> InterpFn
load queryMode = load queryMode =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
StrTable _ _ itos <- use strtable --TODO the argument here should preferably be a string, right? IR.StrTable _ _ itos <- use strtable --TODO the argument here should preferably be a string, right?
case derefHeap heap arg of case derefHeap heap arg of
BoundRef _ (C (Atom a)) -> do BoundRef _ (Atom a) -> do
let fn = itos M.! a let fn = itos M.! a
doLoad queryMode (itos M.! a) doLoad queryMode (itos M.! a)
_ -> prlgError "load needs an atom" _ -> prlgError "load needs an atom"
@ -437,7 +425,7 @@ addPrelude :: PrlgEnv ()
addPrelude = do addPrelude = do
pure undefined pure undefined
{- absolute primitives -} {- absolute primitives -}
addProc [[Done]] "true" 0 addBi (pure Nothing) "true" 0
addBi backtrack "fail" 0 addBi backtrack "fail" 0
addBi stop "stop" 1 addBi stop "stop" 1
addOp $ O.xfx "=" 700 addOp $ O.xfx "=" 700
@ -447,58 +435,27 @@ addPrelude = do
addOp $ O.xfy ";" 1100 addOp $ O.xfy ";" 1100
addOp $ O.xfx ":-" 1200 addOp $ O.xfx ":-" 1200
addOp $ O.fx ":-" 1200 addOp $ O.fx ":-" 1200
do [horn1, horn2] <- traverse (findStruct ":-") [1, 2] horn1 <- findStruct ":-" 1
doCall <- U . Struct <$> findStruct "call" 1 horn2 <- findStruct ":-" 2
let assertCode ac = let assertCode ac =
[ [ U (Struct horn2) [ [ U (Struct horn2)
, U (LocalRef 0) , U (LocalRef 0)
, U (LocalRef 1) , U (LocalRef 1)
, Cut , Cut
, Invoke . bi $ assertRule ac , Invoke . bi $ assertRule ac
] ]
, [ U (Struct horn1) , [U (Struct horn1), U (LocalRef 0), Cut, Invoke $ bi exec]
, U (LocalRef 0) , [U (LocalRef 0), Invoke . bi $ assertFact ac]
, Cut ]
, doCall in do addProc (assertCode addClauseA) "asserta" 1
, U (LocalRef 0) addProc (assertCode addClauseZ) "assertz" 1
, Done addProc (assertCode addClauseZ) "assert" 1
]
, [U (LocalRef 0), Invoke . bi $ assertFact ac]
]
addProc (assertCode addClauseA) "asserta" 1
addProc (assertCode addClauseZ) "assertz" 1
addProc (assertCode addClauseZ) "assert" 1
addBi retractall "retractall" 1 addBi retractall "retractall" 1
do [comma, semi] <- traverse (flip findStruct 2) [",", ";"] addBi call "call" 1
doCall <- U . Struct <$> findStruct "call" 1
addProc
[ [ U (Struct comma)
, U (LocalRef 0)
, U (LocalRef 1)
, Cut
, doCall
, U (LocalRef 0)
, doCall
, U (LocalRef 1)
, Done
]
, [ U (Struct semi)
, U (LocalRef 0)
, U (LocalRef 1)
, Cut
, Choices [[doCall, U (LocalRef 0)], [doCall, U (LocalRef 1)]]
, Done
]
, [U (LocalRef 0), Invoke $ bi call]
]
"call"
1
{- terms -} {- terms -}
addBi struct "struct" 3 addBi struct "struct" 3
addBi var "var" 1 addBi var "var" 1
addBi atom "atom" 1
addBi number "number" 1 addBi number "number" 1
addBi string "string" 1
addBi sameTerm "same_term" 2 addBi sameTerm "same_term" 2
addBi currentPredicate "current_predicate" 1 addBi currentPredicate "current_predicate" 1
{- code loading -} {- code loading -}
@ -532,30 +489,30 @@ addPrelude = do
] ]
("expand_" ++ q) ("expand_" ++ q)
2 2
in do expandCode "load" expandCode "load"
expandCode "query" expandCode "query"
{- int primops -} {- int primops -}
let add2IntOp nm op = addBi (intBinary op) ("int2_" ++ nm) 3 let add2IntOp nm op = addBi (intBinary op) ("int2_" ++ nm) 3
add1IntOp nm op = addBi (intUnary op) ("int1_" ++ nm) 2 add1IntOp nm op = addBi (intUnary op) ("int1_" ++ nm) 2
add2IntPred nm op = addBi (intBinPred op) ("int2p_" ++ nm) 2 add2IntPred nm op = addBi (intBinPred op) ("int2p_" ++ nm) 2
add1IntPred nm op = addBi (intUnPred op) ("int1p_" ++ nm) 1 add1IntPred nm op = addBi (intUnPred op) ("int1p_" ++ nm) 1
in do add2IntOp "add" (+) add2IntOp "add" (+)
add2IntOp "sub" (-) add2IntOp "sub" (-)
add1IntOp "neg" negate add1IntOp "neg" negate
add1IntOp "abs" abs add1IntOp "abs" abs
add2IntOp "mul" (*) add2IntOp "mul" (*)
add2IntOp "div" div add2IntOp "div" div
add2IntOp "mod" mod add2IntOp "mod" mod
add2IntOp "bitand" (.&.) add2IntOp "bitand" (.&.)
add2IntOp "bitor" (.|.) add2IntOp "bitor" (.|.)
add2IntOp "bitxor" xor add2IntOp "bitxor" xor
add2IntOp "shl" shiftL add2IntOp "shl" shiftL
add2IntOp "shr" shiftR add2IntOp "shr" shiftR
add1IntPred "zero" (== 0) add1IntPred "zero" (== 0)
add2IntPred "eq" (==) add2IntPred "eq" (==)
add2IntPred "lt" (<) add2IntPred "lt" (<)
add2IntPred "leq" (<=) add2IntPred "leq" (<=)
add2IntPred "neq" (/=) add2IntPred "neq" (/=)
{- query tools -} {- query tools -}
addBi printLocals "print_locals" 0 addBi printLocals "print_locals" 0
addBi promptRetry' "prompt_retry" 0 addBi promptRetry' "prompt_retry" 0

26
app/Code.hs
View file

@ -2,31 +2,24 @@
module Code where module Code where
import Constant
import Control.Monad.Trans.State.Lazy (StateT) import Control.Monad.Trans.State.Lazy (StateT)
import qualified Data.Map as M import qualified Data.Map as M
import IR (StrTable) import IR (Id(..), StrTable)
import Operators (Ops) import Operators (Ops)
import Parser (PAST) import Parser (PAST)
import System.Console.Haskeline (InputT) import System.Console.Haskeline (InputT)
data Id =
Id
{ str :: !Int
, arity :: !Int
}
deriving (Show, Eq, Ord)
data Datum data Datum
= C !Constant -- unifies a constant = Atom Int -- unifies a symbolic constant
| Struct !Id -- unifies a structure with arity | Number Int -- unifies a numeric constant
| Struct Id -- unifies a structure with arity
| VoidRef -- unifies with anything | VoidRef -- unifies with anything
| LocalRef !Int -- code-local variable idx (should never occur on heap) | LocalRef Int -- code-local variable idx (should never occur on heap)
| HeapRef !Int -- something further on the heap | HeapRef Int -- something further on the heap
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
data Instr data Instr
= U !Datum -- unify/resolve something = U Datum -- unify/resolve something
| Invoke Builtin -- give control to a builtin (invoked from head) | Invoke Builtin -- give control to a builtin (invoked from head)
| Done -- all done, can return | Done -- all done, can return
| Cut -- remove choicepoints of the current goal | Cut -- remove choicepoints of the current goal
@ -38,7 +31,7 @@ type Code = [Instr]
type Defs = M.Map Id [Code] type Defs = M.Map Id [Code]
data Heap = data Heap =
Heap !Int (M.Map Int Datum) Heap Int (M.Map Int Datum)
deriving (Show) deriving (Show)
emptyHeap = Heap 1 M.empty emptyHeap = Heap 1 M.empty
@ -58,8 +51,7 @@ data Cho =
, _retcut :: Bool -- cut after this goal succeeds , _retcut :: Bool -- cut after this goal succeeds
, _heap :: Heap -- a snapshot of the heap (there's no trail; we rely on CoW copies in other choicepoints) , _heap :: Heap -- a snapshot of the heap (there's no trail; we rely on CoW copies in other choicepoints)
, _stk :: [(Code, Scope, [Cho], Bool)] -- remaining goals together with their vars, cuts, and ret-cut flag , _stk :: [(Code, Scope, [Cho], Bool)] -- remaining goals together with their vars, cuts, and ret-cut flag
, _cut :: [Cho] -- snapshot of choicepoints before entering the goal , _cut :: [Cho] -- snapshot of choicepoints before entering
, _hcut :: [Cho] -- save of choicepoints just before starting to match head
} }
deriving (Show) deriving (Show)

74
app/Compiler.hs
View file

@ -1,13 +1,20 @@
module Compiler where module Compiler where
import Constant
import Control.Monad
import Data.Char (isUpper) import Data.Char (isUpper)
import qualified Data.Map as M import qualified Data.Map as M
import Code (Code, Datum(..), Heap, Id(..), Instr(..)) import Code (Code, Datum(..), Heap, Instr(..))
import Heap (heapStruct) import Heap (heapStruct)
import IR (PrlgInt(..), StrTable(..)) import IR (Id(..), PrlgInt(..), StrTable(..))
desugarPrlg :: Int -> PrlgInt -> PrlgInt
desugarPrlg list = go
where
go (CallI id ps) = CallI id $ map go ps
go (ListI (x:xs) t) = CallI list [go x, go (ListI xs t)]
go (ListI [] Nothing) = AtomI list
go (ListI [] (Just x)) = go x
go x = x
varname :: String -> Bool varname :: String -> Bool
varname ('_':_) = True varname ('_':_) = True
@ -16,24 +23,24 @@ varname _ = False
varOccurs :: PrlgInt -> M.Map Int Int varOccurs :: PrlgInt -> M.Map Int Int
varOccurs (CallI _ xs) = M.unionsWith (+) $ map varOccurs xs varOccurs (CallI _ xs) = M.unionsWith (+) $ map varOccurs xs
varOccurs (VarI idx) = M.singleton idx 1 varOccurs (VarI idx _) = M.singleton idx 1
varOccurs _ = M.empty varOccurs _ = M.empty
variablizePrlg :: Int -> StrTable -> PrlgInt -> PrlgInt variablizePrlg :: Int -> StrTable -> PrlgInt -> PrlgInt
variablizePrlg void (StrTable _ _ itos) = go variablizePrlg void (StrTable _ _ itos) = go
where where
go (CallI i ps) = CallI i $ map go ps go (CallI i ps) = CallI i $ map go ps
go o@(ConstI (Atom i)) go (AtomI i)
| i == void = VoidI | i == void = VoidI
| varname (itos M.! i) = VarI i | varname (itos M.! i) = VarI i i
| otherwise = o | otherwise = AtomI i
go x = x go x = x
renumVars :: (Int -> Maybe PrlgInt) -> PrlgInt -> PrlgInt renumVars :: (Int -> Maybe PrlgInt) -> PrlgInt -> PrlgInt
renumVars rename = go renumVars rename = go
where where
go (CallI i ps) = CallI i $ map go ps go (CallI i ps) = CallI i $ map go ps
go (VarI idx) go (VarI idx i)
| Just new <- rename idx = new | Just new <- rename idx = new
go x = x go x = x
@ -43,37 +50,38 @@ squashVars x =
m' = m' =
M.fromList $ M.fromList $
[(idx, VoidI) | (idx, n) <- occurs, n <= 1] ++ [(idx, VoidI) | (idx, n) <- occurs, n <= 1] ++
[(idx, VarI idx') | ((idx, n), idx') <- zip occurs [1 ..], n > 1] [(idx, VarI idx' 0) | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
in renumVars (m' M.!?) x in renumVars (m' M.!?) x
squashChoices :: [Code] -> Either String Code squashChoices :: [Code] -> Code
squashChoices = out . concatMap go squashChoices = out . concatMap go
where where
go [Choices cs] = cs go [Choices cs] = cs
go x = [x] go x = [x]
out [] = Left "goal compilation has no choices?" out [] = error "choice compilation"
out [x] = pure x out [x] = x
out xs = pure [Choices xs] out xs = [Choices xs]
compileGoals :: Int -> Int -> Int -> PrlgInt -> Either String Code compileGoals :: Int -> Int -> Int -> PrlgInt -> Code
compileGoals andop orop cut = fmap (++ [Done]) . go' compileGoals andop orop cut = (++ [Done]) . go'
where where
go' = struct2goal >=> go go' = go . struct2goal
go p@(CallI x args@[_, _]) go p@(CallI x args@[_, _])
| x == andop = concat <$> traverse go' args | x == andop = concatMap go' args
| x == orop = traverse go' args >>= squashChoices | x == orop = squashChoices $ map go' args
go p@(CallI x []) go p@(CallI x [])
| x == cut = pure [Cut] | x == cut = [Cut]
go x = compileGoal x go x = compileGoal x
compileGoal :: PrlgInt -> Either String Code compileGoal :: PrlgInt -> Code
compileGoal = fmap compileArg . struct2goal compileGoal = compileArg . struct2goal
compileArg :: PrlgInt -> Code compileArg :: PrlgInt -> Code
compileArg (CallI i args) = compileArg (CallI i args) =
U (Struct Id {str = i, arity = length args}) : concatMap compileArg args U (Struct Id {str = i, arity = length args}) : concatMap compileArg args
compileArg (ConstI c) = [U (C c)] compileArg (AtomI s) = [U (Atom s)]
compileArg (VarI x) = [U (LocalRef x)] compileArg (NumI s) = [U (Number s)]
compileArg (VarI x _) = [U (LocalRef x)]
compileArg (VoidI) = [U VoidRef] compileArg (VoidI) = [U VoidRef]
seqGoals :: [Code] -> Code seqGoals :: [Code] -> Code
@ -82,14 +90,20 @@ seqGoals = (++ [Done]) . concat
heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt
heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref
where where
atom (C c) = pure (ConstI c) atom (Atom s) = pure $ AtomI s
atom (Number n) = pure $ NumI n
atom VoidRef = pure $ VoidI atom VoidRef = pure $ VoidI
struct (Struct s) args = pure $ CallI (str s) args struct (Struct s) args = pure $ CallI (str s) args
hrec (HeapRef r) ref hrec (HeapRef r) ref
| r == ref = pure $ VarI r | r == ref = pure $ VarI r 0
| otherwise = heaperr | otherwise = heaperr
struct2goal :: PrlgInt -> Either String PrlgInt -- TODO check if this is used
struct2goal (ConstI (Atom s)) = pure $ CallI s [] goal2struct :: PrlgInt -> PrlgInt
struct2goal call@(CallI _ _) = pure call goal2struct (CallI s []) = AtomI s
struct2goal x = Left $ "cannot compile goal: " ++ show x goal2struct x = x
struct2goal :: PrlgInt -> PrlgInt
struct2goal (AtomI s) = CallI s []
struct2goal call@(CallI _ _) = call
struct2goal _ = error "TODO."

7
app/Constant.hs
View file

@ -1,7 +0,0 @@
module Constant where
data Constant
= Atom Int
| Number Int
| Str String
deriving (Show, Eq, Ord)

12
app/Env.hs
View file

@ -1,23 +1,23 @@
module Env where module Env where
import Code (Id(..), InterpFn, PrlgEnv) import Code (InterpFn, PrlgEnv)
import CodeLens import CodeLens
import IR (StrTable, strtablize) import qualified IR
import Lens.Micro.Mtl import Lens.Micro.Mtl
withStrTable :: (StrTable -> (StrTable, a)) -> Env.PrlgEnv a withStrTable :: (IR.StrTable -> (IR.StrTable, a)) -> Env.PrlgEnv a
withStrTable f = do withStrTable f = do
(st', x) <- f <$> use strtable (st', x) <- f <$> use strtable
strtable .= st' strtable .= st'
return x return x
findStruct :: String -> Int -> Env.PrlgEnv Id findStruct :: String -> Int -> Env.PrlgEnv IR.Id
findStruct str arity = do findStruct str arity = do
stri <- findAtom str stri <- findAtom str
return Id {str = stri, arity = arity} return IR.Id {IR.str = stri, IR.arity = arity}
findAtom :: String -> Env.PrlgEnv Int findAtom :: String -> Env.PrlgEnv Int
findAtom = withStrTable . flip strtablize findAtom = withStrTable . flip IR.strtablize
type PrlgEnv a = Code.PrlgEnv a type PrlgEnv a = Code.PrlgEnv a

4
app/Frontend.hs
View file

@ -33,8 +33,8 @@ handleError m = do
processCmd precompileHook ast' = do processCmd precompileHook ast' = do
ast <- shunt ast' ast <- shunt ast'
source <- lift $ intern ast >>= precompileHook code <- lift $ intern ast >>= precompileHook >>= compile
compile source >>= lift . I.prove >>= except lift (I.prove code) >>= except
interpreterStart :: PrlgEnv () interpreterStart :: PrlgEnv ()
interpreterStart = do interpreterStart = do

1
app/Heap.hs
View file

@ -4,6 +4,7 @@ import Code
import CodeLens import CodeLens
import Data.Foldable (traverse_) import Data.Foldable (traverse_)
import qualified Data.Map as M import qualified Data.Map as M
import IR (Id(..))
import Lens.Micro.Mtl import Lens.Micro.Mtl
data Dereferenced data Dereferenced

35
app/IR.hs
View file

@ -1,15 +1,28 @@
module IR where module IR where
import Constant
import Data.Char (isNumber) import Data.Char (isNumber)
import Data.List (mapAccumL) import Data.List (mapAccumL)
import qualified Data.Map as M import qualified Data.Map as M
import Parser (Lexeme(..), PrlgStr(..))
data PrlgStr
= CallS String [PrlgStr]
| LiteralS String
| ListS [PrlgStr] (Maybe PrlgStr)
deriving (Show)
data Id =
Id
{ str :: Int
, arity :: Int
}
deriving (Show, Eq, Ord)
data PrlgInt data PrlgInt
= CallI Int [PrlgInt] = CallI Int [PrlgInt]
| ConstI Constant | AtomI Int
| VarI Int -- VarI localIndex strTableString | NumI Int
| ListI [PrlgInt] (Maybe PrlgInt) -- only exists before desugaring
| VarI Int Int -- VarI localIndex strTableString
| VoidI | VoidI
deriving (Show) deriving (Show)
@ -24,16 +37,16 @@ strtablize t@(StrTable nxt fwd rev) str =
Just i -> (t, i) Just i -> (t, i)
_ -> (StrTable (nxt + 1) (M.insert str nxt fwd) (M.insert nxt str rev), nxt) _ -> (StrTable (nxt + 1) (M.insert str nxt fwd) (M.insert nxt str rev), nxt)
internLexeme t (Tok str)
| all isNumber str = (t, ConstI . Number $ read str)
| otherwise = ConstI . Atom <$> strtablize t str
internLexeme t (QTok str _) = ConstI . Atom <$> strtablize t str
internLexeme t (DQTok str _) = (t, ConstI $ Str str)
internPrlg :: StrTable -> PrlgStr -> (StrTable, PrlgInt) internPrlg :: StrTable -> PrlgStr -> (StrTable, PrlgInt)
internPrlg = go internPrlg = go
where where
go t (LiteralS lex) = internLexeme t lex go t (LiteralS str)
| all isNumber str = (t, NumI $ read str)
| otherwise = AtomI <$> strtablize t str
go t (CallS str ps) = go t (CallS str ps) =
let (t', i) = strtablize t str let (t', i) = strtablize t str
in CallI i <$> mapAccumL go t' ps in CallI i <$> mapAccumL go t' ps
go t (ListS elems Nothing) = flip ListI Nothing <$> mapAccumL go t elems
go t (ListS elems (Just tail)) =
let (t', tail') = go t tail
in flip ListI (Just tail') <$> mapAccumL go t' elems

35
app/Interpreter.hs
View file

@ -8,7 +8,6 @@ import Code
, Cho(..) , Cho(..)
, Code , Code
, Datum(..) , Datum(..)
, Id(..)
, Instr(..) , Instr(..)
, InterpFn , InterpFn
, emptyHeap , emptyHeap
@ -19,7 +18,7 @@ import Control.Monad (when)
import qualified Data.Map as M import qualified Data.Map as M
import Env (PrlgEnv) import Env (PrlgEnv)
import Heap import Heap
import IR (StrTable(..)) import IR (Id(..), StrTable(..))
import Lens.Micro import Lens.Micro
import Lens.Micro.Mtl import Lens.Micro.Mtl
@ -36,7 +35,6 @@ prove g = do
, _heap = emptyHeap , _heap = emptyHeap
, _stk = [] , _stk = []
, _cut = [] , _cut = []
, _hcut = []
} }
cho .= [] cho .= []
loop loop
@ -56,14 +54,10 @@ proveStep = do
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import System.Console.Haskeline import System.Console.Haskeline
g <- use (cur . gol) g <- use (cur . gol)
cho <- use cho
cut <- use (cur . cut)
lift $ do lift $ do
outputStrLn $ "STEP (unis="++show u++")" outputStrLn $ "STEP (unis="++show u++")"
outputStrLn $ "head = "++ show h outputStrLn $ "head = "++ show h
outputStrLn $ "goal = "++ show g outputStrLn $ "goal = "++ show g
outputStrLn $ "cut = " ++ show cut
outputStrLn $ "cho = " ++ show cho
-} -}
case (u, h) of case (u, h) of
(0, []) -> goalStep (0, []) -> goalStep
@ -98,7 +92,7 @@ headStep h = do
case (h, g) of case (h, g) of
([Done], _) -> succeedHead ([Done], _) -> succeedHead
(Cut:_, _) -> cutHead (Cut:_, _) -> cutHead
(Invoke (Builtin bf):_, _) -> cur . hed .= [Done] >> bf (Invoke (Builtin bf):_, _) -> advanceHead >> bf
(_, [Done]) -> tailCall (_, [Done]) -> tailCall
(_, [Cut, Done]) -> tailCut (_, [Cut, Done]) -> tailCut
(_, _) -> pushCall (_, _) -> pushCall
@ -140,13 +134,11 @@ retCut = do
doCut doCut
cur . retcut .= False cur . retcut .= False
cutHead = do cutHead = doCut >> advanceHead
use (cur . hcut) >>= assign cho
advanceHead
cutGoal = doCut >> advance cutGoal = doCut >> advance
openGoal :: Id -> InterpFn openGoal :: IR.Id -> InterpFn
openGoal fn = do openGoal fn = do
def <- (M.!? fn) <$> use defs def <- (M.!? fn) <$> use defs
case def of case def of
@ -155,8 +147,7 @@ openGoal fn = do
cur . hvar .= emptyScope cur . hvar .= emptyScope
cur . unis .= arity fn cur . unis .= arity fn
cc <- use cur cc <- use cur
oldcho <- use cho let (newcur:newcho) = [cc & hed .~ h | h <- hs]
let (newcur:newcho) = [cc & hcut .~ oldcho & hed .~ h | h <- hs]
cur .= newcur cur .= newcur
cho %= (newcho ++) cho %= (newcho ++)
continue continue
@ -171,15 +162,12 @@ pushCall = do
ngol <- use (cur . hed) ngol <- use (cur . hed)
ngvar <- use (cur . hvar) ngvar <- use (cur . hvar)
scut <- use (cur . cut) scut <- use (cur . cut)
ncut <- use (cur . hcut)
sretcut <- use (cur . retcut) sretcut <- use (cur . retcut)
cur . stk %= ((sgol, sgvar, scut, sretcut) :) cur . stk %= ((sgol, sgvar, scut, sretcut) :)
cur . gol .= ngol cur . gol .= ngol
cur . gvar .= ngvar cur . gvar .= ngvar
cur . cut .= ncut
cur . hed .= [] cur . hed .= []
cur . hvar .= emptyScope cur . hvar .= emptyScope
cur . hcut .= []
cur . retcut .= False cur . retcut .= False
continue continue
@ -191,7 +179,6 @@ tailCall = do
cur . gvar .= ngvar cur . gvar .= ngvar
cur . hed .= [] cur . hed .= []
cur . hvar .= emptyScope cur . hvar .= emptyScope
cur . hcut .= []
continue continue
tailCut :: InterpFn tailCut :: InterpFn
@ -202,9 +189,8 @@ tailCut = do
succeedHead :: InterpFn succeedHead :: InterpFn
succeedHead = do succeedHead = do
cur . hed .= []
cur . hvar .= emptyScope cur . hvar .= emptyScope
cur . hcut .= [] cur . hed .= []
continue continue
succeedGoal :: InterpFn succeedGoal :: InterpFn
@ -245,10 +231,13 @@ uOK = uNext >> continue
unify :: Datum -> Datum -> InterpFn unify :: Datum -> Datum -> InterpFn
unify VoidRef VoidRef = uOK unify VoidRef VoidRef = uOK
unify (C _) VoidRef = uOK unify (Atom _) VoidRef = uOK
unify VoidRef (C _) = uOK unify VoidRef (Atom _) = uOK
unify (C a) (C b) unify (Atom a) (Atom b)
| a == b = uOK | a == b = uOK
unify (Number _) VoidRef = uOK
unify VoidRef (Number _) = uOK
unify (Number a) (Number b)
| a == b = uOK | a == b = uOK
unify (Struct a) VoidRef = do unify (Struct a) VoidRef = do
uNext uNext

22
app/Load.hs
View file

@ -1,6 +1,6 @@
module Load where module Load where
import Code (Code, Id(..), PrlgEnv) import Code (Code, PrlgEnv)
import CodeLens import CodeLens
import qualified Compiler as C import qualified Compiler as C
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
@ -21,23 +21,27 @@ tokenize fn = left MP.errorBundlePretty . MP.parse P.lexPrlg fn
parse :: String -> [P.Lexeme] -> Either String [P.PAST] parse :: String -> [P.Lexeme] -> Either String [P.PAST]
parse fn = left MP.errorBundlePretty . MP.parse P.parsePrlg fn parse fn = left MP.errorBundlePretty . MP.parse P.parsePrlg fn
shunt :: P.PAST -> ExceptT String PrlgEnv P.PrlgStr shunt :: P.PAST -> ExceptT String PrlgEnv IR.PrlgStr
shunt past = do shunt past = do
ops <- lift $ use ops ops <- lift $ use ops
except . left (\err -> "operator resolution: " ++ err ++ "\n") $ except . left (\err -> "operator resolution: " ++ err ++ "\n") $
P.shuntPrlg ops past P.shuntPrlg ops past
intern :: P.PrlgStr -> PrlgEnv IR.PrlgInt intern :: IR.PrlgStr -> PrlgEnv IR.PrlgInt
intern prlgs = do intern prlgs = do
prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs
underscore <- findAtom "_" underscore <- findAtom "_"
list <- findAtom "[]"
withStrTable $ \st -> withStrTable $ \st ->
(st, C.squashVars $ C.variablizePrlg underscore st prlgi) ( st
, C.squashVars $ C.variablizePrlg underscore st $ C.desugarPrlg list prlgi)
compile :: IR.PrlgInt -> ExceptT String PrlgEnv Code compile :: IR.PrlgInt -> PrlgEnv Code
compile prlgv = do compile prlgv = do
[comma, semi, cut] <- lift $ traverse findAtom [",", ";", "!"] comma <- findAtom ","
except $ C.compileGoals comma semi cut prlgv semi <- findAtom ";"
cut <- findAtom "!"
return $ C.compileGoals comma semi cut prlgv
expansion :: expansion ::
(Int -> IR.PrlgInt -> IR.PrlgInt) (Int -> IR.PrlgInt -> IR.PrlgInt)
@ -54,7 +58,9 @@ expansion noexpand expander output x = do
if expand if expand
then IR.CallI then IR.CallI
comma comma
[IR.CallI (str es) [x, IR.VarI (-1)], IR.CallI o [IR.VarI (-1)]] [ IR.CallI (IR.str es) [x, IR.VarI (-1) 0]
, IR.CallI o [IR.VarI (-1) 0]
]
else noexpand o x else noexpand o x
queryExpansion = expansion (\_ -> id) "expand_query" "call" queryExpansion = expansion (\_ -> id) "expand_query" "call"

78
app/Parser.hs
View file

@ -5,8 +5,7 @@ module Parser
, parsePrlg , parsePrlg
, shuntPrlg , shuntPrlg
, PAST , PAST
, Lexeme(..) , Lexeme
, PrlgStr(..)
) where ) where
import Control.Monad (void) import Control.Monad (void)
@ -43,13 +42,14 @@ import Text.Megaparsec
) )
import Text.Megaparsec.Char (string) import Text.Megaparsec.Char (string)
import IR (PrlgStr(..))
import Operators (ArgKind(..), Fixity(..), Op(..), Ops) import Operators (ArgKind(..), Fixity(..), Op(..), Ops)
singleToks = ",;|()[]{}!" singleToks = ",;|()[]{}!"
identParts = "_" identParts = "_"
notOpToks = "'\"" ++ identParts notOpToks = "\'" ++ identParts
isOperatorlike x = isOperatorlike x =
(isSymbol x || isPunctuation x) && not (x `elem` singleToks ++ notOpToks) (isSymbol x || isPunctuation x) && not (x `elem` singleToks ++ notOpToks)
@ -64,7 +64,6 @@ data Lexeme
= Blank String = Blank String
| Tok String | Tok String
| QTok String String -- unquoted quoted | QTok String String -- unquoted quoted
| DQTok String String -- unquoted quoted
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
blank :: Lexer Lexeme blank :: Lexer Lexeme
@ -87,15 +86,14 @@ qtok = do
z <- string "'" z <- string "'"
return $ QTok y (x ++ y ++ z) return $ QTok y (x ++ y ++ z)
dqtok :: Lexer Lexeme cmt :: Lexer Lexeme
dqtok = do cmt =
x <- string "\"" Blank . concat <$>
y <- many $ satisfy (/= '\"') -- TODO actual escaping sequence
z <- string "\"" [string "%", many $ satisfy (/= '\n'), choice [string "\n", "" <$ eof]]
return $ DQTok y (x ++ y ++ z)
lexeme :: Lexer Lexeme lexeme :: Lexer Lexeme
lexeme = choice [blank, tok, qtok, dqtok] lexeme = choice [blank, tok, qtok, cmt]
lexPrlg :: Lexer [Lexeme] lexPrlg :: Lexer [Lexeme]
lexPrlg = many lexeme <* (many blank >> eof) lexPrlg = many lexeme <* (many blank >> eof)
@ -103,7 +101,6 @@ lexPrlg = many lexeme <* (many blank >> eof)
showTok (Blank x) = x showTok (Blank x) = x
showTok (Tok x) = x showTok (Tok x) = x
showTok (QTok _ x) = x showTok (QTok _ x) = x
showTok (DQTok _ x) = x
instance VisualStream [Lexeme] where instance VisualStream [Lexeme] where
showTokens _ (a :| b) = concatMap showTok (a : b) showTokens _ (a :| b) = concatMap showTok (a : b)
@ -149,9 +146,9 @@ instance TraversableStream [Lexeme] where
data PAST data PAST
= Call String [[PAST]] = Call String [[PAST]]
| Group [PAST] | Seq [PAST]
| List [[PAST]] (Maybe [PAST]) | List [[PAST]] (Maybe [PAST])
| Literal Lexeme | Literal String
deriving (Show, Eq) deriving (Show, Eq)
type Parser = Parsec Void [Lexeme] type Parser = Parsec Void [Lexeme]
@ -168,46 +165,43 @@ isNormalTokStr = (`notElem` [".", "[", "]", "(", "|", ")", "{", "}"])
isNormalTok :: Lexeme -> Bool isNormalTok :: Lexeme -> Bool
isNormalTok (Tok x) = isNormalTokStr x isNormalTok (Tok x) = isNormalTokStr x
isNormalTok (QTok _ _) = True isNormalTok (QTok _ _) = True
isNormalTok (DQTok _ _) = True
isNormalTok _ = False isNormalTok _ = False
isCallTok :: Lexeme -> Bool isCallTok :: Lexeme -> Bool
isCallTok (Tok x) = isCallTok (Tok x) =
all (\c -> not (isSymbol c) && not (isPunctuation c) || c `elem` identParts) x all (\c -> not (isSymbol c) && not (isPunctuation c) || c `elem` identParts) x
isCallTok (QTok _ _) = True isCallTok _ = True
isCallTok _ = False
unTok (Tok t) = t unTok (Tok t) = t
unTok (QTok t _) = t unTok (QTok t _) = t
unTok (DQTok t _) = t
literal :: Parser PAST literal :: Parser PAST
literal = literal =
Literal <$> Literal . unTok <$>
free free
(choice (choice
[ satisfy isCallTok <* notFollowedBy (choice [lParen, lBrace]) [ satisfy isCallTok <* notFollowedBy (choice [lParen, lBrace])
, satisfy (\x -> not (isCallTok x) && isNormalTok x) , satisfy (\x -> not (isCallTok x) && isNormalTok x)
]) ])
makeParams (Group inner) = splitOn [Literal (Tok ",")] inner makeParams (Seq inner) = splitOn [Literal ","] inner
call eb contents fmod = do call eb contents fmod = do
fn <- fmod . unTok <$> satisfy isCallTok -- not free fn <- fmod . unTok <$> satisfy isCallTok -- not free
(Call fn [] <$ try eb) <|> (Call fn . makeParams <$> free contents) (Call fn [] <$ try eb) <|> (Call fn . makeParams <$> free contents)
parens = Group <$> (free lParen *> some seqItem <* free rParen) parens = Seq <$> (free lParen *> some seqItem <* free rParen)
braces = Group <$> (free lBrace *> some seqItem <* free rBrace) braces = Seq <$> (free lBrace *> some seqItem <* free rBrace)
emptyParens = Literal (QTok "()" "()") <$ (free lParen >> free rParen) emptyParens = Literal "()" <$ (free lParen >> free rParen)
emptyBraces = Literal (QTok "{}" "{}") <$ (free lBrace >> free rBrace) emptyBraces = Literal "{}" <$ (free lBrace >> free rBrace)
list = do list = do
free lBracket free lBracket
(List [] Nothing <$ free rBracket) <|> do (List [] Nothing <$ free rBracket) <|> do
items <- splitOn [Literal (Tok ",")] <$> some seqItem items <- splitOn [Literal ","] <$> some seqItem
(List items Nothing <$ free rBracket) <|> (List items Nothing <$ free rBracket) <|>
(List items . Just <$> (free listTail *> some seqItem <* free rBracket)) (List items . Just <$> (free listTail *> some seqItem <* free rBracket))
@ -243,7 +237,7 @@ lBrace = simpleTok "{"
rBrace = simpleTok "}" rBrace = simpleTok "}"
clause :: Parser PAST clause :: Parser PAST
clause = Group <$> some (free seqItem) <* free period clause = Seq <$> some (free seqItem) <* free period
parsePrlg :: Parser [PAST] parsePrlg :: Parser [PAST]
parsePrlg = ws *> many clause <* eof parsePrlg = ws *> many clause <* eof
@ -252,11 +246,6 @@ type ShuntError = String
type ShuntResult = Either ShuntError PrlgStr type ShuntResult = Either ShuntError PrlgStr
data PrlgStr
= CallS String [PrlgStr]
| LiteralS Lexeme
deriving (Show)
err :: ShuntError -> Either ShuntError a err :: ShuntError -> Either ShuntError a
err = Left err = Left
@ -265,10 +254,8 @@ shuntPrlg ot = shuntPrlg' (("", Op 0 $ Infix Y X) : ot)
shuntPrlg' :: Ops -> PAST -> ShuntResult shuntPrlg' :: Ops -> PAST -> ShuntResult
shuntPrlg' ot (List hs t) = shuntPrlg' ot (List hs t) =
foldr (\x y -> CallS "[]" [x, y]) <$> ListS <$> traverse (shunt ot) hs <*> traverse (shunt ot) t
(maybe (LiteralS $ Tok "[]") id <$> traverse (shunt ot) t) <*> shuntPrlg' ot (Seq ss) = shunt ot ss
traverse (shunt ot) hs
shuntPrlg' ot (Group ss) = shunt ot ss
shuntPrlg' ot (Literal s) = pure (LiteralS s) shuntPrlg' ot (Literal s) = pure (LiteralS s)
shuntPrlg' ot (Call fn ss) = CallS fn <$> traverse (shunt ot) ss shuntPrlg' ot (Call fn ss) = CallS fn <$> traverse (shunt ot) ss
@ -309,13 +296,13 @@ shunt optable = start
(ops', vs') <- pushInfix ops vs x (ops', vs') <- pushInfix ops vs x
wo ops' vs' xs wo ops' vs' xs
, do getOperand x , do getOperand x
ho ops vs (Literal (Tok "") : xs') -- app (see below) ho ops vs (Literal "" : xs') -- app (see below)
, do getPrefix x , do getPrefix x
ho ops vs (Literal (Tok "") : xs') -- also app! ho ops vs (Literal "" : xs') -- also app!
, err "expected infix or suffix operator" , err "expected infix or suffix operator"
] ]
{- incoming non-literal operand; there must be an app in between -} {- incoming non-literal operand; there must be an app in between -}
ho ops vs xs@(_:_) = ho ops vs (Literal (Tok "") : xs) ho ops vs xs@(_:_) = ho ops vs (Literal "" : xs)
{- the last operand was last, pop until finished -} {- the last operand was last, pop until finished -}
ho [] [res] [] = pure res ho [] [res] [] = pure res
ho ops vs [] = do ho ops vs [] = do
@ -332,14 +319,11 @@ shunt optable = start
{- Operator checks -} {- Operator checks -}
uniq [x] = pure x uniq [x] = pure x
uniq _ = err "ambiguous operator" uniq _ = err "ambiguous operator"
getPrefix t = getPrefix x = uniq [op | (s, op@(Op _ (Prefix _))) <- optable, s == x]
uniq [op | Tok x <- [t], (s, op@(Op _ (Prefix _))) <- optable, s == x] getSuffix x = uniq [op | (s, op@(Op _ (Suffix _))) <- optable, s == x]
getSuffix t = getInfix x = uniq [op | (s, op@(Op _ (Infix _ _))) <- optable, s == x]
uniq [op | Tok x <- [t], (s, op@(Op _ (Suffix _))) <- optable, s == x] getOperand x
getInfix t = | null [op | (s, op) <- optable, s == x] = pure ()
uniq [op | Tok x <- [t], (s, op@(Op _ (Infix _ _))) <- optable, s == x]
getOperand t
| null [op | Tok x <- [t], (s, op) <- optable, s == x] = pure ()
| otherwise = err "expected an operand" | otherwise = err "expected an operand"
{- actual pushery -} {- actual pushery -}
canPush :: Ops -> Op -> Either ShuntError Bool canPush :: Ops -> Op -> Either ShuntError Bool
@ -387,7 +371,7 @@ shunt optable = start
shunt1 ops vs x op = do shunt1 ops vs x op = do
cp <- canPush ops op cp <- canPush ops op
if cp if cp
then pure ((unTok x, op) : ops, vs) then pure ((x, op) : ops, vs)
else do else do
(ops', vs') <- pop ops vs (ops', vs') <- pop ops vs
shunt1 ops' vs' x op --prefix would behave differently here but that's impossible by canPush shunt1 ops' vs' x op --prefix would behave differently here but that's impossible by canPush

55
inst/prelude.pl
View file

@ -1,13 +1,9 @@
member(X, [X|_]). member(X, [X|_]).
member(X, [_|T]) :- member(X,T). member(X, [_|T]) :- member(X,T).
append([], [], []). append([], X, X).
append([], [H|T], [H|T]).
append([X|T], Y, [X|TY]) :- append(T,Y,TY). append([X|T], Y, [X|TY]) :- append(T,Y,TY).
list([]).
list([_|_]).
:- op(700, xfx, is), :- op(700, xfx, is),
op(700, xfx, <), op(700, xfx, <),
op(700, xfx, =<), op(700, xfx, =<),
@ -49,44 +45,17 @@ Ax > Bx :- A is Ax, B is Bx, int2p_lt(B,A).
Ax >= Bx :- A is Ax, B is Bx, int2p_leq(B,A). Ax >= Bx :- A is Ax, B is Bx, int2p_leq(B,A).
zero(Ax) :- A is Ax, int1p_zero(A). zero(Ax) :- A is Ax, int1p_zero(A).
gcd(X,Y,R) :- Y > X, !, gcd(Y,X,R). gcd(X,Y,R) :- writeln(a), fail.
gcd(X,Y,R) :- zero(Y), !, R=X. gcd(X,Y,R) :- writeln(b), zero(Y), !, R=X.
gcd(X,Y,R) :- X1 is X mod Y, gcd(Y,X1,R). gcd(X,Y,R) :- writeln(c), X1 is X mod Y, gcd(Y,X1,R).
gcd(X,Y,R) :- writeln(a), Y > X, writeln(wat), !, gcd(Y,X,R).
gcd(X,Y,R) :- writeln(b), zero(Y), !, R=X.
gcd(X,Y,R) :- writeln(c), X1 is X mod Y, gcd(Y,X1,R).
lcm(X,Y,R) :- gcd(X,Y,GCD), R is X*(Y/GCD). test(X) :- writeln(there), zero(X), fail.
test(X) :- writeln(here).
:- op(1200, xfx, -->). test :- writeln(a), a=a, !, fail.
test :- writeln(b).
sequence([], SameState, SameState) :- !. xxx :- test.
sequence(Tokens, ParsedList, Rest) :-
append(Tokens, Rest, ParsedList).
load_expansion((X, L) --> Y, Xp :- (Yp, Lp)) :- !,
expand_phrasecall(X, Xp, S0, S),
expand_phrase(Y, Yp, S0, S),
expand_phrase(L, Lp, S, _).
load_expansion(X --> Y, Xp :- Yp) :- !,
expand_phrasecall(X, Xp, S0, S),
expand_phrase(Y, Yp, S0, S).
expand_phrase((A, B), (Ap, Bp), S0, S) :- !,
expand_phrase(A, Ap, S0, S1),
expand_phrase(B, Bp, S1, S).
expand_phrase((A; B), (Ap; Bp), S0, S) :- !,
expand_phrase(A, Ap, S0, S),
expand_phrase(B, Bp, S0, S).
expand_phrase(L, sequence(L, S0, S), S0, S) :- list(L), !.
expand_phrase({X}, X, S, S) :- !.
expand_phrase(!, !, S, S) :- !.
expand_phrase(X, Xp, S0, S) :- expand_phrasecall(X, Xp, S0, S).
expand_phrasecall(X, Xp, S0, S) :-
atom(X), !,
struct(Xp, X, [S0, S]).
expand_phrasecall(X, Xp, S0, S) :- !,
struct(X, Id, Args),
append(Args, [S0, S], Args1),
struct(Xp, Id, Args1).
phrase(X, S0, S) :- expand_phrasecall(X, Xp, S0, S), call(Xp).

30
prlg.cabal
View file

@ -21,40 +21,18 @@ maintainer: exa.exa@gmail.com
-- category: -- category:
extra-source-files: CHANGELOG.md extra-source-files: CHANGELOG.md
data-dir: inst data-dir: inst
data-files: *.pl data-files: *.pl
executable prlg executable prlg
main-is: Main.hs main-is: Main.hs
-- Modules included in this executable, other than Main. -- Modules included in this executable, other than Main.
other-modules: Paths_prlg, other-modules: Interpreter, Compiler, Parser, Frontend, IR, Operators, Code, Builtins, Env, Load, CodeLens, Heap, Paths_prlg
Builtins,
Code,
CodeLens,
Compiler,
Constant,
Env,
Frontend,
Heap,
Interpreter,
IR,
Load,
Operators,
Parser
-- LANGUAGE extensions used by modules in this package. -- LANGUAGE extensions used by modules in this package.
-- other-extensions: -- other-extensions:
build-depends: base >=4.14, build-depends: base >=4.14, containers, megaparsec, haskeline, split, transformers, microlens, microlens-th, microlens-mtl
containers,
haskeline,
megaparsec,
microlens,
microlens-mtl,
microlens-th,
split,
transformers
hs-source-dirs: app hs-source-dirs: app
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wunused-imports ghc-options: -Wunused-imports