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

strings and a few other small nice changes

Browse source
This commit is contained in:
Mirek Kratochvil 2023-03-05 21:34:20 +01:00
parent 45c3f81891
commit 98c40f4bf8
10 changed files with 200 additions and 173 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

130
app/Builtins.hs
View file

@ -2,9 +2,10 @@ module Builtins where
import Paths_prlg import Paths_prlg
import Code (Builtin(..), Code, Datum(..), Instr(..), InterpFn) import Code (Builtin(..), Code, Datum(..), Id(..), 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)
@ -16,7 +17,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 qualified IR import IR (PrlgInt(..), StrTable(..))
import Interpreter (backtrack) import Interpreter (backtrack)
import Lens.Micro.Mtl import Lens.Micro.Mtl
import Load (processInput) import Load (processInput)
@ -29,10 +30,11 @@ continue = pure Nothing
showTerm itos heap = runIdentity . heapStruct atom struct hrec heap showTerm itos heap = runIdentity . heapStruct atom struct hrec heap
where where
atom (Atom a) = pure $ "'" ++ itos M.! a ++ "'" atom (C (Atom a)) = pure $ "'" ++ itos M.! a ++ "'"
atom (Number n) = pure (show n) atom (C (Number n)) = pure (show n)
atom (C (Str str)) = pure (show str)
atom VoidRef = pure "_" atom VoidRef = pure "_"
struct (Struct (IR.Id h _)) args = struct (Struct (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 $
@ -45,7 +47,7 @@ printLocals :: InterpFn
printLocals = do printLocals = do
scope <- use (cur . gvar) scope <- use (cur . gvar)
heap <- use (cur . heap) heap <- use (cur . heap)
IR.StrTable _ _ itos <- use strtable 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
@ -76,7 +78,7 @@ write' :: InterpFn -> InterpFn
write' c = write' c =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
IR.StrTable _ _ itos <- use strtable 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
@ -90,7 +92,7 @@ nl = do
writeln :: InterpFn writeln :: InterpFn
writeln = write' nl writeln = write' nl
assertFact :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn assertFact :: (Code -> Id -> PrlgEnv ()) -> InterpFn
assertFact addClause = assertFact addClause =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
@ -101,7 +103,7 @@ assertFact addClause =
continue continue
_ -> prlgError "assert fact failure" _ -> prlgError "assert fact failure"
assertRule :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn assertRule :: (Code -> 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)
@ -123,8 +125,8 @@ 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 _ (Atom a) -> BoundRef _ (C (Atom a)) ->
dropProcedure (IR.Id {IR.arity = 0, IR.str = a}) >> continue dropProcedure (Id {arity = 0, 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"
@ -153,7 +155,7 @@ exec = exec' (const [Done])
stop :: InterpFn stop :: InterpFn
stop = stop =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
IR.StrTable _ _ itos <- use strtable StrTable _ _ itos <- use strtable
heap <- use (cur . heap) heap <- use (cur . heap)
prlgError $ "stop: " ++ showTerm itos heap arg prlgError $ "stop: " ++ showTerm itos heap arg
@ -163,17 +165,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 addr (Struct IR.Id {IR.arity = arity, IR.str = str})) -> Just (BoundRef addr (Struct Id {arity = arity, str = str})) ->
structUnify arity str structUnify arity str
_ -> 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 == Atom listAtom | BoundRef _ str <- derefHeap heap r = str == C (Atom listAtom)
| otherwise = False | otherwise = False
step r step r
| BoundRef addr (Struct IR.Id {IR.arity = 2, IR.str = listAtom'}) <- | BoundRef addr (Struct Id {arity = 2, str = listAtom'}) <-
derefHeap heap r derefHeap heap r
, listAtom == listAtom' = Just (addr + 2) , listAtom == listAtom' = Just (addr + 2)
| otherwise = Nothing | otherwise = Nothing
@ -190,7 +192,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 (Atom str)) -> do Just (BoundRef addr (C (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
@ -203,14 +205,13 @@ 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 = structData = Struct Id {arity = arity, str = str} : map HeapRef pvars
Struct IR.Id {IR.arity = arity, IR.str = str} : map HeapRef pvars
paramsData = paramsData =
concatMap concatMap
(\pv -> [Struct IR.Id {IR.arity = 2, IR.str = listAtom}, HeapRef pv]) (\pv -> [Struct Id {arity = 2, str = listAtom}, HeapRef pv])
pvars ++ pvars ++
[Atom listAtom] [C $ Atom listAtom]
gcode = map U $ structData ++ [Atom str] ++ paramsData gcode = map U $ structData ++ [C $ Atom str] ++ paramsData
zoom cur $ do zoom cur $ do
gol %= (gcode ++) gol %= (gcode ++)
hed %= (hcode ++) hed %= (hcode ++)
@ -231,7 +232,16 @@ 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 _ (Number _)) -> continue Just (BoundRef _ (C (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
@ -260,9 +270,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)
IR.StrTable _ _ itos <- use strtable StrTable _ _ itos <- use strtable
case map (derefHeap heap) args of case map (derefHeap heap) args of
[BoundRef _ (Number prio), BoundRef _ (Atom fixityAtom), BoundRef _ (Atom opatom)] [BoundRef _ (C (Number prio)), BoundRef _ (C (Atom fixityAtom)), BoundRef _ (C (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
@ -274,9 +284,9 @@ deop :: InterpFn
deop = deop =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
IR.StrTable _ _ itos <- use strtable StrTable _ _ itos <- use strtable
case derefHeap heap arg of case derefHeap heap arg of
BoundRef _ (Atom opatom) BoundRef _ (C (Atom opatom))
| Just op <- itos M.!? opatom -> do | Just op <- itos M.!? opatom -> do
ops %= filter ((/= op) . fst) ops %= filter ((/= op) . fst)
continue continue
@ -326,7 +336,8 @@ 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 _ (Number n1), BoundRef _ (Number n2)] -> putInt (op n1 n2) 2 [BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] ->
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
@ -334,7 +345,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 _ (Number n1), BoundRef _ (Number n2)] -> [BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] ->
if op n1 n2 if op n1 n2
then continue then continue
else backtrack else backtrack
@ -345,7 +356,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 _ (Number n) -> putInt (op n) 1 BoundRef _ (C (Number n)) -> putInt (op n) 1
_ -> prlgError "int unary needs number" _ -> prlgError "int unary needs number"
intUnPred :: (Int -> Bool) -> InterpFn intUnPred :: (Int -> Bool) -> InterpFn
@ -353,7 +364,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 _ (Number n) -> BoundRef _ (C (Number n)) ->
if op n if op n
then continue then continue
else backtrack else backtrack
@ -366,28 +377,28 @@ putInt val sc = do
Nothing -> continue Nothing -> continue
Just a -> Just a ->
case derefHeap heap a of case derefHeap heap a of
BoundRef _ (Number val') BoundRef _ (C (Number val'))
| val == val' -> continue | val == val' -> continue
FreeRef a' -> writeHeap a' (Number val) >> continue FreeRef a' -> writeHeap a' (C (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]) -> IR.Id -> PrlgEnv () modDef :: ([Code] -> Maybe [Code]) -> Id -> PrlgEnv ()
modDef fn struct = defs %= M.alter (maybe (fn []) fn) struct modDef fn struct = defs %= M.alter (maybe (fn []) fn) struct
addClauseA :: Code -> IR.Id -> PrlgEnv () addClauseA :: Code -> Id -> PrlgEnv ()
addClauseA code = modDef $ Just . (code :) addClauseA code = modDef $ Just . (code :)
addClauseZ :: Code -> IR.Id -> PrlgEnv () addClauseZ :: Code -> Id -> PrlgEnv ()
addClauseZ code = modDef $ Just . (++ [code]) addClauseZ code = modDef $ Just . (++ [code])
addProcedure :: [Code] -> IR.Id -> PrlgEnv () addProcedure :: [Code] -> Id -> PrlgEnv ()
addProcedure heads = modDef $ Just . const heads addProcedure heads = modDef $ Just . const heads
dropProcedure :: IR.Id -> PrlgEnv () dropProcedure :: Id -> PrlgEnv ()
dropProcedure = modDef $ const Nothing dropProcedure = modDef $ const Nothing
addProc :: [Code] -> String -> Int -> PrlgEnv () addProc :: [Code] -> String -> Int -> PrlgEnv ()
@ -413,9 +424,9 @@ load :: Bool -> InterpFn
load queryMode = load queryMode =
withArgs [0] $ \[arg] -> do withArgs [0] $ \[arg] -> do
heap <- use (cur . heap) heap <- use (cur . heap)
IR.StrTable _ _ itos <- use strtable --TODO the argument here should preferably be a string, right? 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 _ (Atom a) -> do BoundRef _ (C (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"
@ -425,7 +436,7 @@ addPrelude :: PrlgEnv ()
addPrelude = do addPrelude = do
pure undefined pure undefined
{- absolute primitives -} {- absolute primitives -}
addBi (pure Nothing) "true" 0 addProc [[Done]] "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
@ -456,6 +467,7 @@ addPrelude = do
addBi struct "struct" 3 addBi struct "struct" 3
addBi var "var" 1 addBi var "var" 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 -}
@ -489,30 +501,30 @@ addPrelude = do
] ]
("expand_" ++ q) ("expand_" ++ q)
2 2
expandCode "load" in do 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
add2IntOp "add" (+) in do 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

23
app/Code.hs
View file

@ -2,24 +2,31 @@
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 (Id(..), StrTable) import IR (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
= Atom Int -- unifies a symbolic constant = C !Constant -- unifies a constant
| Number Int -- unifies a numeric constant | Struct !Id -- unifies a structure with arity
| 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
@ -31,7 +38,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

40
app/Compiler.hs
View file

@ -1,20 +1,12 @@
module Compiler where module Compiler where
import Constant
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, Instr(..)) import Code (Code, Datum(..), Heap, Id(..), Instr(..))
import Heap (heapStruct) import Heap (heapStruct)
import IR (Id(..), PrlgInt(..), StrTable(..)) import IR (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
@ -23,24 +15,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 (AtomI i) go o@(ConstI (Atom i))
| i == void = VoidI | i == void = VoidI
| varname (itos M.! i) = VarI i i | varname (itos M.! i) = VarI i
| otherwise = AtomI i | otherwise = o
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 i) go (VarI idx)
| Just new <- rename idx = new | Just new <- rename idx = new
go x = x go x = x
@ -50,7 +42,7 @@ 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' 0) | ((idx, n), idx') <- zip occurs [1 ..], n > 1] [(idx, VarI idx') | ((idx, n), idx') <- zip occurs [1 ..], n > 1]
in renumVars (m' M.!?) x in renumVars (m' M.!?) x
squashChoices :: [Code] -> Code squashChoices :: [Code] -> Code
@ -79,9 +71,8 @@ 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 (AtomI s) = [U (Atom s)] compileArg (ConstI c) = [U (C c)]
compileArg (NumI s) = [U (Number s)] compileArg (VarI x) = [U (LocalRef x)]
compileArg (VarI x _) = [U (LocalRef x)]
compileArg (VoidI) = [U VoidRef] compileArg (VoidI) = [U VoidRef]
seqGoals :: [Code] -> Code seqGoals :: [Code] -> Code
@ -90,20 +81,19 @@ 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 (Atom s) = pure $ AtomI s atom (C c) = pure (ConstI c)
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 0 | r == ref = pure $ VarI r
| otherwise = heaperr | otherwise = heaperr
-- TODO check if this is used -- TODO check if this is used
goal2struct :: PrlgInt -> PrlgInt goal2struct :: PrlgInt -> PrlgInt
goal2struct (CallI s []) = AtomI s goal2struct (CallI s []) = ConstI (Atom s)
goal2struct x = x goal2struct x = x
struct2goal :: PrlgInt -> PrlgInt struct2goal :: PrlgInt -> PrlgInt
struct2goal (AtomI s) = CallI s [] struct2goal (ConstI (Atom s)) = CallI s []
struct2goal call@(CallI _ _) = call struct2goal call@(CallI _ _) = call
struct2goal _ = error "TODO." struct2goal _ = error "TODO."

12
app/Env.hs
View file

@ -1,23 +1,23 @@
module Env where module Env where
import Code (InterpFn, PrlgEnv) import Code (Id(..), InterpFn, PrlgEnv)
import CodeLens import CodeLens
import qualified IR import IR (StrTable, strtablize)
import Lens.Micro.Mtl import Lens.Micro.Mtl
withStrTable :: (IR.StrTable -> (IR.StrTable, a)) -> Env.PrlgEnv a withStrTable :: (StrTable -> (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 IR.Id findStruct :: String -> Int -> Env.PrlgEnv Id
findStruct str arity = do findStruct str arity = do
stri <- findAtom str stri <- findAtom str
return IR.Id {IR.str = stri, IR.arity = arity} return Id {str = stri, arity = arity}
findAtom :: String -> Env.PrlgEnv Int findAtom :: String -> Env.PrlgEnv Int
findAtom = withStrTable . flip IR.strtablize findAtom = withStrTable . flip strtablize
type PrlgEnv a = Code.PrlgEnv a type PrlgEnv a = Code.PrlgEnv a

1
app/Heap.hs
View file

@ -4,7 +4,6 @@ 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,28 +1,15 @@
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]
| AtomI Int | ConstI Constant
| NumI Int | VarI Int -- VarI localIndex strTableString
| ListI [PrlgInt] (Maybe PrlgInt) -- only exists before desugaring
| VarI Int Int -- VarI localIndex strTableString
| VoidI | VoidI
deriving (Show) deriving (Show)
@ -37,16 +24,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 str) go t (LiteralS lex) = internLexeme t lex
| 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

14
app/Interpreter.hs
View file

@ -8,6 +8,7 @@ import Code
, Cho(..) , Cho(..)
, Code , Code
, Datum(..) , Datum(..)
, Id(..)
, Instr(..) , Instr(..)
, InterpFn , InterpFn
, emptyHeap , emptyHeap
@ -18,7 +19,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 (Id(..), StrTable(..)) import IR (StrTable(..))
import Lens.Micro import Lens.Micro
import Lens.Micro.Mtl import Lens.Micro.Mtl
@ -145,7 +146,7 @@ cutHead = do
cutGoal = doCut >> advance cutGoal = doCut >> advance
openGoal :: IR.Id -> InterpFn openGoal :: Id -> InterpFn
openGoal fn = do openGoal fn = do
def <- (M.!? fn) <$> use defs def <- (M.!? fn) <$> use defs
case def of case def of
@ -244,13 +245,10 @@ uOK = uNext >> continue
unify :: Datum -> Datum -> InterpFn unify :: Datum -> Datum -> InterpFn
unify VoidRef VoidRef = uOK unify VoidRef VoidRef = uOK
unify (Atom _) VoidRef = uOK unify (C _) VoidRef = uOK
unify VoidRef (Atom _) = uOK unify VoidRef (C _) = uOK
unify (Atom a) (Atom b) unify (C a) (C 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

13
app/Load.hs
View file

@ -1,6 +1,6 @@
module Load where module Load where
import Code (Code, PrlgEnv) import Code (Code, Id(..), 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,20 +21,19 @@ 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 IR.PrlgStr shunt :: P.PAST -> ExceptT String PrlgEnv P.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 :: IR.PrlgStr -> PrlgEnv IR.PrlgInt intern :: P.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 "[]" list <- findAtom "[]"
withStrTable $ \st -> withStrTable $ \st ->
( st (st, C.squashVars $ C.variablizePrlg underscore st prlgi)
, C.squashVars $ C.variablizePrlg underscore st $ C.desugarPrlg list prlgi)
compile :: IR.PrlgInt -> PrlgEnv Code compile :: IR.PrlgInt -> PrlgEnv Code
compile prlgv = do compile prlgv = do
@ -58,9 +57,7 @@ expansion noexpand expander output x = do
if expand if expand
then IR.CallI then IR.CallI
comma comma
[ IR.CallI (IR.str es) [x, IR.VarI (-1) 0] [IR.CallI (str es) [x, IR.VarI (-1)], IR.CallI o [IR.VarI (-1)]]
, 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"

75
app/Parser.hs
View file

@ -5,7 +5,8 @@ module Parser
, parsePrlg , parsePrlg
, shuntPrlg , shuntPrlg
, PAST , PAST
, Lexeme , Lexeme(..)
, PrlgStr(..)
) where ) where
import Control.Monad (void) import Control.Monad (void)
@ -42,14 +43,13 @@ 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,6 +64,7 @@ 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
@ -86,14 +87,15 @@ qtok = do
z <- string "'" z <- string "'"
return $ QTok y (x ++ y ++ z) return $ QTok y (x ++ y ++ z)
cmt :: Lexer Lexeme dqtok :: Lexer Lexeme
cmt = dqtok = do
Blank . concat <$> x <- string "\""
sequence y <- many $ satisfy (/= '\"') -- TODO actual escaping
[string "%", many $ satisfy (/= '\n'), choice [string "\n", "" <$ eof]] z <- string "\""
return $ DQTok y (x ++ y ++ z)
lexeme :: Lexer Lexeme lexeme :: Lexer Lexeme
lexeme = choice [blank, tok, qtok, cmt] lexeme = choice [blank, tok, qtok, dqtok]
lexPrlg :: Lexer [Lexeme] lexPrlg :: Lexer [Lexeme]
lexPrlg = many lexeme <* (many blank >> eof) lexPrlg = many lexeme <* (many blank >> eof)
@ -101,6 +103,7 @@ 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)
@ -146,9 +149,9 @@ instance TraversableStream [Lexeme] where
data PAST data PAST
= Call String [[PAST]] = Call String [[PAST]]
| Seq [PAST] | Group [PAST]
| List [[PAST]] (Maybe [PAST]) | List [[PAST]] (Maybe [PAST])
| Literal String | Literal Lexeme
deriving (Show, Eq) deriving (Show, Eq)
type Parser = Parsec Void [Lexeme] type Parser = Parsec Void [Lexeme]
@ -165,6 +168,7 @@ 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
@ -174,34 +178,35 @@ isCallTok _ = True
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 . unTok <$> Literal <$>
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 (Seq inner) = splitOn [Literal ","] inner makeParams (Group inner) = splitOn [Literal (Tok ",")] 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 = Seq <$> (free lParen *> some seqItem <* free rParen) parens = Group <$> (free lParen *> some seqItem <* free rParen)
braces = Seq <$> (free lBrace *> some seqItem <* free rBrace) braces = Group <$> (free lBrace *> some seqItem <* free rBrace)
emptyParens = Literal "()" <$ (free lParen >> free rParen) emptyParens = Literal (QTok "()" "()") <$ (free lParen >> free rParen)
emptyBraces = Literal "{}" <$ (free lBrace >> free rBrace) emptyBraces = Literal (QTok "{}" "{}") <$ (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 ","] <$> some seqItem items <- splitOn [Literal (Tok ",")] <$> 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))
@ -237,7 +242,7 @@ lBrace = simpleTok "{"
rBrace = simpleTok "}" rBrace = simpleTok "}"
clause :: Parser PAST clause :: Parser PAST
clause = Seq <$> some (free seqItem) <* free period clause = Group <$> some (free seqItem) <* free period
parsePrlg :: Parser [PAST] parsePrlg :: Parser [PAST]
parsePrlg = ws *> many clause <* eof parsePrlg = ws *> many clause <* eof
@ -246,6 +251,11 @@ 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
@ -254,8 +264,10 @@ 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) =
ListS <$> traverse (shunt ot) hs <*> traverse (shunt ot) t foldr (\x y -> CallS "[]" [x, y]) <$>
shuntPrlg' ot (Seq ss) = shunt ot ss (maybe (LiteralS $ Tok "[]") id <$> traverse (shunt ot) t) <*>
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
@ -296,13 +308,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 "" : xs') -- app (see below) ho ops vs (Literal (Tok "") : xs') -- app (see below)
, do getPrefix x , do getPrefix x
ho ops vs (Literal "" : xs') -- also app! ho ops vs (Literal (Tok "") : 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 "" : xs) ho ops vs xs@(_:_) = ho ops vs (Literal (Tok "") : 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
@ -319,11 +331,14 @@ shunt optable = start
{- Operator checks -} {- Operator checks -}
uniq [x] = pure x uniq [x] = pure x
uniq _ = err "ambiguous operator" uniq _ = err "ambiguous operator"
getPrefix x = uniq [op | (s, op@(Op _ (Prefix _))) <- optable, s == x] getPrefix t =
getSuffix x = uniq [op | (s, op@(Op _ (Suffix _))) <- optable, s == x] uniq [op | Tok x <- [t], (s, op@(Op _ (Prefix _))) <- optable, s == x]
getInfix x = uniq [op | (s, op@(Op _ (Infix _ _))) <- optable, s == x] getSuffix t =
getOperand x uniq [op | Tok x <- [t], (s, op@(Op _ (Suffix _))) <- optable, s == x]
| null [op | (s, op) <- optable, s == x] = pure () getInfix t =
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
@ -371,7 +386,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 ((x, op) : ops, vs) then pure ((unTok 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

30
prlg.cabal
View file

@ -21,18 +21,40 @@ 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: Interpreter, Compiler, Parser, Frontend, IR, Operators, Code, Builtins, Env, Load, CodeLens, Heap, Paths_prlg other-modules: 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, containers, megaparsec, haskeline, split, transformers, microlens, microlens-th, microlens-mtl build-depends: base >=4.14,
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