strings and a few other small nice changes
This commit is contained in:
parent
45c3f81891
commit
98c40f4bf8
|
|
@ -2,9 +2,10 @@ module Builtins where
|
|||
|
||||
import Paths_prlg
|
||||
|
||||
import Code (Builtin(..), Code, Datum(..), Instr(..), InterpFn)
|
||||
import Code (Builtin(..), Code, Datum(..), Id(..), Instr(..), InterpFn)
|
||||
import CodeLens
|
||||
import qualified Compiler as Co
|
||||
import Constant
|
||||
import Control.Exception (IOException, catch)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
|
|
@ -16,7 +17,7 @@ import qualified Data.Map as M
|
|||
import Data.Maybe (fromJust)
|
||||
import Env (PrlgEnv(..), findAtom, findStruct, prlgError)
|
||||
import Heap (Dereferenced(..), derefHeap, heapStruct, newHeapVars, writeHeap)
|
||||
import qualified IR
|
||||
import IR (PrlgInt(..), StrTable(..))
|
||||
import Interpreter (backtrack)
|
||||
import Lens.Micro.Mtl
|
||||
import Load (processInput)
|
||||
|
|
@ -29,10 +30,11 @@ continue = pure Nothing
|
|||
|
||||
showTerm itos heap = runIdentity . heapStruct atom struct hrec heap
|
||||
where
|
||||
atom (Atom a) = pure $ "'" ++ itos M.! a ++ "'"
|
||||
atom (Number n) = pure (show n)
|
||||
atom (C (Atom a)) = pure $ "'" ++ itos M.! a ++ "'"
|
||||
atom (C (Number n)) = pure (show n)
|
||||
atom (C (Str str)) = pure (show str)
|
||||
atom VoidRef = pure "_"
|
||||
struct (Struct (IR.Id h _)) args =
|
||||
struct (Struct (Id h _)) args =
|
||||
pure $ "'" ++ itos M.! h ++ "'(" ++ intercalate "," args ++ ")"
|
||||
hrec (HeapRef hr) ref =
|
||||
pure $
|
||||
|
|
@ -45,7 +47,7 @@ printLocals :: InterpFn
|
|||
printLocals = do
|
||||
scope <- use (cur . gvar)
|
||||
heap <- use (cur . heap)
|
||||
IR.StrTable _ _ itos <- use strtable
|
||||
StrTable _ _ itos <- use strtable
|
||||
flip traverse (M.assocs scope) $ \(local, ref) ->
|
||||
lift . outputStrLn $ "_Local" ++ show local ++ " = " ++
|
||||
showTerm itos heap ref
|
||||
|
|
@ -76,7 +78,7 @@ write' :: InterpFn -> InterpFn
|
|||
write' c =
|
||||
withArgs [0] $ \[arg] -> do
|
||||
heap <- use (cur . heap)
|
||||
IR.StrTable _ _ itos <- use strtable
|
||||
StrTable _ _ itos <- use strtable
|
||||
lift . outputStr $ showTerm itos heap arg
|
||||
c --this now allows error fallthrough but we might like EitherT
|
||||
|
||||
|
|
@ -90,7 +92,7 @@ nl = do
|
|||
writeln :: InterpFn
|
||||
writeln = write' nl
|
||||
|
||||
assertFact :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
|
||||
assertFact :: (Code -> Id -> PrlgEnv ()) -> InterpFn
|
||||
assertFact addClause =
|
||||
withArgs [0] $ \[arg] -> do
|
||||
heap <- use (cur . heap)
|
||||
|
|
@ -101,7 +103,7 @@ assertFact addClause =
|
|||
continue
|
||||
_ -> prlgError "assert fact failure"
|
||||
|
||||
assertRule :: (Code -> IR.Id -> PrlgEnv ()) -> InterpFn
|
||||
assertRule :: (Code -> Id -> PrlgEnv ()) -> InterpFn
|
||||
assertRule addClause =
|
||||
withArgs [0, 1] $ \args -> do
|
||||
scope <- use (cur . hvar)
|
||||
|
|
@ -123,8 +125,8 @@ retractall =
|
|||
withArgs [0] $ \[arg] -> do
|
||||
heap <- use (cur . heap)
|
||||
case derefHeap heap arg of
|
||||
BoundRef _ (Atom a) ->
|
||||
dropProcedure (IR.Id {IR.arity = 0, IR.str = a}) >> continue
|
||||
BoundRef _ (C (Atom a)) ->
|
||||
dropProcedure (Id {arity = 0, str = a}) >> continue
|
||||
BoundRef _ (Struct id) -> dropProcedure id >> continue
|
||||
_ -> prlgError "retractall needs a struct"
|
||||
|
||||
|
|
@ -153,7 +155,7 @@ exec = exec' (const [Done])
|
|||
stop :: InterpFn
|
||||
stop =
|
||||
withArgs [0] $ \[arg] -> do
|
||||
IR.StrTable _ _ itos <- use strtable
|
||||
StrTable _ _ itos <- use strtable
|
||||
heap <- use (cur . heap)
|
||||
prlgError $ "stop: " ++ showTerm itos heap arg
|
||||
|
||||
|
|
@ -163,17 +165,17 @@ struct = do
|
|||
heap <- use (cur . heap)
|
||||
scope <- use (cur . hvar)
|
||||
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
|
||||
_ -> structAssemble
|
||||
|
||||
heapListLength listAtom heap ref = go 0 ref ref (id, fromJust . step)
|
||||
where
|
||||
nil r
|
||||
| BoundRef _ str <- derefHeap heap r = str == Atom listAtom
|
||||
| BoundRef _ str <- derefHeap heap r = str == C (Atom listAtom)
|
||||
| otherwise = False
|
||||
step r
|
||||
| BoundRef addr (Struct IR.Id {IR.arity = 2, IR.str = listAtom'}) <-
|
||||
| BoundRef addr (Struct Id {arity = 2, str = listAtom'}) <-
|
||||
derefHeap heap r
|
||||
, listAtom == listAtom' = Just (addr + 2)
|
||||
| otherwise = Nothing
|
||||
|
|
@ -190,7 +192,7 @@ structAssemble = do
|
|||
heap <- use (cur . heap)
|
||||
scope <- use (cur . hvar)
|
||||
case derefHeap heap <$> scope M.!? 1 of
|
||||
Just (BoundRef addr (Atom str)) -> do
|
||||
Just (BoundRef addr (C (Atom str))) -> do
|
||||
listAtom <- findAtom "[]"
|
||||
case scope M.!? 2 >>= heapListLength listAtom heap of
|
||||
Just arity -> structUnify arity str
|
||||
|
|
@ -203,14 +205,13 @@ structUnify arity str = do
|
|||
listAtom <- findAtom "[]"
|
||||
pvars <- newHeapVars arity
|
||||
let hcode = map U $ maybe VoidRef HeapRef . (scope M.!?) <$> [0 .. 2]
|
||||
structData =
|
||||
Struct IR.Id {IR.arity = arity, IR.str = str} : map HeapRef pvars
|
||||
structData = Struct Id {arity = arity, str = str} : map HeapRef pvars
|
||||
paramsData =
|
||||
concatMap
|
||||
(\pv -> [Struct IR.Id {IR.arity = 2, IR.str = listAtom}, HeapRef pv])
|
||||
(\pv -> [Struct Id {arity = 2, str = listAtom}, HeapRef pv])
|
||||
pvars ++
|
||||
[Atom listAtom]
|
||||
gcode = map U $ structData ++ [Atom str] ++ paramsData
|
||||
[C $ Atom listAtom]
|
||||
gcode = map U $ structData ++ [C $ Atom str] ++ paramsData
|
||||
zoom cur $ do
|
||||
gol %= (gcode ++)
|
||||
hed %= (hcode ++)
|
||||
|
|
@ -231,7 +232,16 @@ number = do
|
|||
heap <- use (cur . heap)
|
||||
scope <- use (cur . hvar)
|
||||
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
|
||||
|
||||
sameTerm :: InterpFn
|
||||
|
|
@ -260,9 +270,9 @@ op :: InterpFn
|
|||
op =
|
||||
withArgs [0, 1, 2] $ \args -> do
|
||||
heap <- use (cur . heap)
|
||||
IR.StrTable _ _ itos <- use strtable
|
||||
StrTable _ _ itos <- use strtable
|
||||
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 <-
|
||||
(,) <$> itos M.!? opatom <*>
|
||||
(O.Op prio <$> ((itos M.!? fixityAtom) >>= O.fixity)) -> do
|
||||
|
|
@ -274,9 +284,9 @@ deop :: InterpFn
|
|||
deop =
|
||||
withArgs [0] $ \[arg] -> do
|
||||
heap <- use (cur . heap)
|
||||
IR.StrTable _ _ itos <- use strtable
|
||||
StrTable _ _ itos <- use strtable
|
||||
case derefHeap heap arg of
|
||||
BoundRef _ (Atom opatom)
|
||||
BoundRef _ (C (Atom opatom))
|
||||
| Just op <- itos M.!? opatom -> do
|
||||
ops %= filter ((/= op) . fst)
|
||||
continue
|
||||
|
|
@ -326,7 +336,8 @@ intBinary op =
|
|||
withArgs [0, 1] $ \[arg1, arg2] -> do
|
||||
heap <- use (cur . heap)
|
||||
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"
|
||||
|
||||
intBinPred :: (Int -> Int -> Bool) -> InterpFn
|
||||
|
|
@ -334,7 +345,7 @@ intBinPred op =
|
|||
withArgs [0, 1] $ \args -> do
|
||||
heap <- use (cur . heap)
|
||||
case derefHeap heap <$> args of
|
||||
[BoundRef _ (Number n1), BoundRef _ (Number n2)] ->
|
||||
[BoundRef _ (C (Number n1)), BoundRef _ (C (Number n2))] ->
|
||||
if op n1 n2
|
||||
then continue
|
||||
else backtrack
|
||||
|
|
@ -345,7 +356,7 @@ intUnary op =
|
|||
withArgs [0] $ \[arg] -> do
|
||||
heap <- use (cur . heap)
|
||||
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"
|
||||
|
||||
intUnPred :: (Int -> Bool) -> InterpFn
|
||||
|
|
@ -353,7 +364,7 @@ intUnPred op =
|
|||
withArgs [0] $ \[arg] -> do
|
||||
heap <- use (cur . heap)
|
||||
case derefHeap heap arg of
|
||||
BoundRef _ (Number n) ->
|
||||
BoundRef _ (C (Number n)) ->
|
||||
if op n
|
||||
then continue
|
||||
else backtrack
|
||||
|
|
@ -366,28 +377,28 @@ putInt val sc = do
|
|||
Nothing -> continue
|
||||
Just a ->
|
||||
case derefHeap heap a of
|
||||
BoundRef _ (Number val')
|
||||
BoundRef _ (C (Number val'))
|
||||
| val == val' -> continue
|
||||
FreeRef a' -> writeHeap a' (Number val) >> continue
|
||||
FreeRef a' -> writeHeap a' (C (Number val)) >> continue
|
||||
_ -> backtrack
|
||||
|
||||
{- adding the builtins -}
|
||||
addOp :: (String, O.Op) -> PrlgEnv ()
|
||||
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
|
||||
|
||||
addClauseA :: Code -> IR.Id -> PrlgEnv ()
|
||||
addClauseA :: Code -> Id -> PrlgEnv ()
|
||||
addClauseA code = modDef $ Just . (code :)
|
||||
|
||||
addClauseZ :: Code -> IR.Id -> PrlgEnv ()
|
||||
addClauseZ :: Code -> Id -> PrlgEnv ()
|
||||
addClauseZ code = modDef $ Just . (++ [code])
|
||||
|
||||
addProcedure :: [Code] -> IR.Id -> PrlgEnv ()
|
||||
addProcedure :: [Code] -> Id -> PrlgEnv ()
|
||||
addProcedure heads = modDef $ Just . const heads
|
||||
|
||||
dropProcedure :: IR.Id -> PrlgEnv ()
|
||||
dropProcedure :: Id -> PrlgEnv ()
|
||||
dropProcedure = modDef $ const Nothing
|
||||
|
||||
addProc :: [Code] -> String -> Int -> PrlgEnv ()
|
||||
|
|
@ -413,9 +424,9 @@ load :: Bool -> InterpFn
|
|||
load queryMode =
|
||||
withArgs [0] $ \[arg] -> do
|
||||
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
|
||||
BoundRef _ (Atom a) -> do
|
||||
BoundRef _ (C (Atom a)) -> do
|
||||
let fn = itos M.! a
|
||||
doLoad queryMode (itos M.! a)
|
||||
_ -> prlgError "load needs an atom"
|
||||
|
|
@ -425,7 +436,7 @@ addPrelude :: PrlgEnv ()
|
|||
addPrelude = do
|
||||
pure undefined
|
||||
{- absolute primitives -}
|
||||
addBi (pure Nothing) "true" 0
|
||||
addProc [[Done]] "true" 0
|
||||
addBi backtrack "fail" 0
|
||||
addBi stop "stop" 1
|
||||
addOp $ O.xfx "=" 700
|
||||
|
|
@ -456,6 +467,7 @@ addPrelude = do
|
|||
addBi struct "struct" 3
|
||||
addBi var "var" 1
|
||||
addBi number "number" 1
|
||||
addBi string "string" 1
|
||||
addBi sameTerm "same_term" 2
|
||||
addBi currentPredicate "current_predicate" 1
|
||||
{- code loading -}
|
||||
|
|
@ -489,14 +501,14 @@ addPrelude = do
|
|||
]
|
||||
("expand_" ++ q)
|
||||
2
|
||||
expandCode "load"
|
||||
in do expandCode "load"
|
||||
expandCode "query"
|
||||
{- int primops -}
|
||||
let add2IntOp nm op = addBi (intBinary op) ("int2_" ++ nm) 3
|
||||
add1IntOp nm op = addBi (intUnary op) ("int1_" ++ nm) 2
|
||||
add2IntPred nm op = addBi (intBinPred op) ("int2p_" ++ nm) 2
|
||||
add1IntPred nm op = addBi (intUnPred op) ("int1p_" ++ nm) 1
|
||||
add2IntOp "add" (+)
|
||||
in do add2IntOp "add" (+)
|
||||
add2IntOp "sub" (-)
|
||||
add1IntOp "neg" negate
|
||||
add1IntOp "abs" abs
|
||||
|
|
|
|||
23
app/Code.hs
23
app/Code.hs
|
|
@ -2,24 +2,31 @@
|
|||
|
||||
module Code where
|
||||
|
||||
import Constant
|
||||
import Control.Monad.Trans.State.Lazy (StateT)
|
||||
import qualified Data.Map as M
|
||||
import IR (Id(..), StrTable)
|
||||
import IR (StrTable)
|
||||
import Operators (Ops)
|
||||
import Parser (PAST)
|
||||
import System.Console.Haskeline (InputT)
|
||||
|
||||
data Id =
|
||||
Id
|
||||
{ str :: !Int
|
||||
, arity :: !Int
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Datum
|
||||
= Atom Int -- unifies a symbolic constant
|
||||
| Number Int -- unifies a numeric constant
|
||||
| Struct Id -- unifies a structure with arity
|
||||
= C !Constant -- unifies a constant
|
||||
| Struct !Id -- unifies a structure with arity
|
||||
| VoidRef -- unifies with anything
|
||||
| LocalRef Int -- code-local variable idx (should never occur on heap)
|
||||
| HeapRef Int -- something further on the heap
|
||||
| LocalRef !Int -- code-local variable idx (should never occur on heap)
|
||||
| HeapRef !Int -- something further on the heap
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data Instr
|
||||
= U Datum -- unify/resolve something
|
||||
= U !Datum -- unify/resolve something
|
||||
| Invoke Builtin -- give control to a builtin (invoked from head)
|
||||
| Done -- all done, can return
|
||||
| Cut -- remove choicepoints of the current goal
|
||||
|
|
@ -31,7 +38,7 @@ type Code = [Instr]
|
|||
type Defs = M.Map Id [Code]
|
||||
|
||||
data Heap =
|
||||
Heap Int (M.Map Int Datum)
|
||||
Heap !Int (M.Map Int Datum)
|
||||
deriving (Show)
|
||||
|
||||
emptyHeap = Heap 1 M.empty
|
||||
|
|
|
|||
|
|
@ -1,20 +1,12 @@
|
|||
module Compiler where
|
||||
|
||||
import Constant
|
||||
import Data.Char (isUpper)
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Code (Code, Datum(..), Heap, Instr(..))
|
||||
import Code (Code, Datum(..), Heap, Id(..), Instr(..))
|
||||
import Heap (heapStruct)
|
||||
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
|
||||
import IR (PrlgInt(..), StrTable(..))
|
||||
|
||||
varname :: String -> Bool
|
||||
varname ('_':_) = True
|
||||
|
|
@ -23,24 +15,24 @@ varname _ = False
|
|||
|
||||
varOccurs :: PrlgInt -> M.Map Int Int
|
||||
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
|
||||
|
||||
variablizePrlg :: Int -> StrTable -> PrlgInt -> PrlgInt
|
||||
variablizePrlg void (StrTable _ _ itos) = go
|
||||
where
|
||||
go (CallI i ps) = CallI i $ map go ps
|
||||
go (AtomI i)
|
||||
go o@(ConstI (Atom i))
|
||||
| i == void = VoidI
|
||||
| varname (itos M.! i) = VarI i i
|
||||
| otherwise = AtomI i
|
||||
| varname (itos M.! i) = VarI i
|
||||
| otherwise = o
|
||||
go x = x
|
||||
|
||||
renumVars :: (Int -> Maybe PrlgInt) -> PrlgInt -> PrlgInt
|
||||
renumVars rename = go
|
||||
where
|
||||
go (CallI i ps) = CallI i $ map go ps
|
||||
go (VarI idx i)
|
||||
go (VarI idx)
|
||||
| Just new <- rename idx = new
|
||||
go x = x
|
||||
|
||||
|
|
@ -50,7 +42,7 @@ squashVars x =
|
|||
m' =
|
||||
M.fromList $
|
||||
[(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
|
||||
|
||||
squashChoices :: [Code] -> Code
|
||||
|
|
@ -79,9 +71,8 @@ compileGoal = compileArg . struct2goal
|
|||
compileArg :: PrlgInt -> Code
|
||||
compileArg (CallI i args) =
|
||||
U (Struct Id {str = i, arity = length args}) : concatMap compileArg args
|
||||
compileArg (AtomI s) = [U (Atom s)]
|
||||
compileArg (NumI s) = [U (Number s)]
|
||||
compileArg (VarI x _) = [U (LocalRef x)]
|
||||
compileArg (ConstI c) = [U (C c)]
|
||||
compileArg (VarI x) = [U (LocalRef x)]
|
||||
compileArg (VoidI) = [U VoidRef]
|
||||
|
||||
seqGoals :: [Code] -> Code
|
||||
|
|
@ -90,20 +81,19 @@ seqGoals = (++ [Done]) . concat
|
|||
heapStructPrlgInt :: Monad m => m PrlgInt -> Heap -> Int -> m PrlgInt
|
||||
heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref
|
||||
where
|
||||
atom (Atom s) = pure $ AtomI s
|
||||
atom (Number n) = pure $ NumI n
|
||||
atom (C c) = pure (ConstI c)
|
||||
atom VoidRef = pure $ VoidI
|
||||
struct (Struct s) args = pure $ CallI (str s) args
|
||||
hrec (HeapRef r) ref
|
||||
| r == ref = pure $ VarI r 0
|
||||
| r == ref = pure $ VarI r
|
||||
| otherwise = heaperr
|
||||
|
||||
-- TODO check if this is used
|
||||
goal2struct :: PrlgInt -> PrlgInt
|
||||
goal2struct (CallI s []) = AtomI s
|
||||
goal2struct (CallI s []) = ConstI (Atom s)
|
||||
goal2struct x = x
|
||||
|
||||
struct2goal :: PrlgInt -> PrlgInt
|
||||
struct2goal (AtomI s) = CallI s []
|
||||
struct2goal (ConstI (Atom s)) = CallI s []
|
||||
struct2goal call@(CallI _ _) = call
|
||||
struct2goal _ = error "TODO."
|
||||
|
|
|
|||
12
app/Env.hs
12
app/Env.hs
|
|
@ -1,23 +1,23 @@
|
|||
module Env where
|
||||
|
||||
import Code (InterpFn, PrlgEnv)
|
||||
import Code (Id(..), InterpFn, PrlgEnv)
|
||||
import CodeLens
|
||||
import qualified IR
|
||||
import IR (StrTable, strtablize)
|
||||
import Lens.Micro.Mtl
|
||||
|
||||
withStrTable :: (IR.StrTable -> (IR.StrTable, a)) -> Env.PrlgEnv a
|
||||
withStrTable :: (StrTable -> (StrTable, a)) -> Env.PrlgEnv a
|
||||
withStrTable f = do
|
||||
(st', x) <- f <$> use strtable
|
||||
strtable .= st'
|
||||
return x
|
||||
|
||||
findStruct :: String -> Int -> Env.PrlgEnv IR.Id
|
||||
findStruct :: String -> Int -> Env.PrlgEnv Id
|
||||
findStruct str arity = do
|
||||
stri <- findAtom str
|
||||
return IR.Id {IR.str = stri, IR.arity = arity}
|
||||
return Id {str = stri, arity = arity}
|
||||
|
||||
findAtom :: String -> Env.PrlgEnv Int
|
||||
findAtom = withStrTable . flip IR.strtablize
|
||||
findAtom = withStrTable . flip strtablize
|
||||
|
||||
type PrlgEnv a = Code.PrlgEnv a
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,6 @@ import Code
|
|||
import CodeLens
|
||||
import Data.Foldable (traverse_)
|
||||
import qualified Data.Map as M
|
||||
import IR (Id(..))
|
||||
import Lens.Micro.Mtl
|
||||
|
||||
data Dereferenced
|
||||
|
|
|
|||
35
app/IR.hs
35
app/IR.hs
|
|
@ -1,28 +1,15 @@
|
|||
module IR where
|
||||
|
||||
import Constant
|
||||
import Data.Char (isNumber)
|
||||
import Data.List (mapAccumL)
|
||||
import qualified Data.Map as M
|
||||
|
||||
data PrlgStr
|
||||
= CallS String [PrlgStr]
|
||||
| LiteralS String
|
||||
| ListS [PrlgStr] (Maybe PrlgStr)
|
||||
deriving (Show)
|
||||
|
||||
data Id =
|
||||
Id
|
||||
{ str :: Int
|
||||
, arity :: Int
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
import Parser (Lexeme(..), PrlgStr(..))
|
||||
|
||||
data PrlgInt
|
||||
= CallI Int [PrlgInt]
|
||||
| AtomI Int
|
||||
| NumI Int
|
||||
| ListI [PrlgInt] (Maybe PrlgInt) -- only exists before desugaring
|
||||
| VarI Int Int -- VarI localIndex strTableString
|
||||
| ConstI Constant
|
||||
| VarI Int -- VarI localIndex strTableString
|
||||
| VoidI
|
||||
deriving (Show)
|
||||
|
||||
|
|
@ -37,16 +24,16 @@ strtablize t@(StrTable nxt fwd rev) str =
|
|||
Just i -> (t, i)
|
||||
_ -> (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 = go
|
||||
where
|
||||
go t (LiteralS str)
|
||||
| all isNumber str = (t, NumI $ read str)
|
||||
| otherwise = AtomI <$> strtablize t str
|
||||
go t (LiteralS lex) = internLexeme t lex
|
||||
go t (CallS str ps) =
|
||||
let (t', i) = strtablize t str
|
||||
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
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ import Code
|
|||
, Cho(..)
|
||||
, Code
|
||||
, Datum(..)
|
||||
, Id(..)
|
||||
, Instr(..)
|
||||
, InterpFn
|
||||
, emptyHeap
|
||||
|
|
@ -18,7 +19,7 @@ import Control.Monad (when)
|
|||
import qualified Data.Map as M
|
||||
import Env (PrlgEnv)
|
||||
import Heap
|
||||
import IR (Id(..), StrTable(..))
|
||||
import IR (StrTable(..))
|
||||
import Lens.Micro
|
||||
import Lens.Micro.Mtl
|
||||
|
||||
|
|
@ -145,7 +146,7 @@ cutHead = do
|
|||
|
||||
cutGoal = doCut >> advance
|
||||
|
||||
openGoal :: IR.Id -> InterpFn
|
||||
openGoal :: Id -> InterpFn
|
||||
openGoal fn = do
|
||||
def <- (M.!? fn) <$> use defs
|
||||
case def of
|
||||
|
|
@ -244,13 +245,10 @@ uOK = uNext >> continue
|
|||
|
||||
unify :: Datum -> Datum -> InterpFn
|
||||
unify VoidRef VoidRef = uOK
|
||||
unify (Atom _) VoidRef = uOK
|
||||
unify VoidRef (Atom _) = uOK
|
||||
unify (Atom a) (Atom b)
|
||||
unify (C _) VoidRef = uOK
|
||||
unify VoidRef (C _) = uOK
|
||||
unify (C a) (C b)
|
||||
| a == b = uOK
|
||||
unify (Number _) VoidRef = uOK
|
||||
unify VoidRef (Number _) = uOK
|
||||
unify (Number a) (Number b)
|
||||
| a == b = uOK
|
||||
unify (Struct a) VoidRef = do
|
||||
uNext
|
||||
|
|
|
|||
13
app/Load.hs
13
app/Load.hs
|
|
@ -1,6 +1,6 @@
|
|||
module Load where
|
||||
|
||||
import Code (Code, PrlgEnv)
|
||||
import Code (Code, Id(..), PrlgEnv)
|
||||
import CodeLens
|
||||
import qualified Compiler as C
|
||||
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 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
|
||||
ops <- lift $ use ops
|
||||
except . left (\err -> "operator resolution: " ++ err ++ "\n") $
|
||||
P.shuntPrlg ops past
|
||||
|
||||
intern :: IR.PrlgStr -> PrlgEnv IR.PrlgInt
|
||||
intern :: P.PrlgStr -> PrlgEnv IR.PrlgInt
|
||||
intern prlgs = do
|
||||
prlgi <- withStrTable $ \st -> IR.internPrlg st prlgs
|
||||
underscore <- findAtom "_"
|
||||
list <- findAtom "[]"
|
||||
withStrTable $ \st ->
|
||||
( st
|
||||
, C.squashVars $ C.variablizePrlg underscore st $ C.desugarPrlg list prlgi)
|
||||
(st, C.squashVars $ C.variablizePrlg underscore st prlgi)
|
||||
|
||||
compile :: IR.PrlgInt -> PrlgEnv Code
|
||||
compile prlgv = do
|
||||
|
|
@ -58,9 +57,7 @@ expansion noexpand expander output x = do
|
|||
if expand
|
||||
then IR.CallI
|
||||
comma
|
||||
[ IR.CallI (IR.str es) [x, IR.VarI (-1) 0]
|
||||
, IR.CallI o [IR.VarI (-1) 0]
|
||||
]
|
||||
[IR.CallI (str es) [x, IR.VarI (-1)], IR.CallI o [IR.VarI (-1)]]
|
||||
else noexpand o x
|
||||
|
||||
queryExpansion = expansion (\_ -> id) "expand_query" "call"
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ module Parser
|
|||
, parsePrlg
|
||||
, shuntPrlg
|
||||
, PAST
|
||||
, Lexeme
|
||||
, Lexeme(..)
|
||||
, PrlgStr(..)
|
||||
) where
|
||||
|
||||
import Control.Monad (void)
|
||||
|
|
@ -42,14 +43,13 @@ import Text.Megaparsec
|
|||
)
|
||||
import Text.Megaparsec.Char (string)
|
||||
|
||||
import IR (PrlgStr(..))
|
||||
import Operators (ArgKind(..), Fixity(..), Op(..), Ops)
|
||||
|
||||
singleToks = ",;|()[]{}!"
|
||||
|
||||
identParts = "_"
|
||||
|
||||
notOpToks = "\'" ++ identParts
|
||||
notOpToks = "'\"" ++ identParts
|
||||
|
||||
isOperatorlike x =
|
||||
(isSymbol x || isPunctuation x) && not (x `elem` singleToks ++ notOpToks)
|
||||
|
|
@ -64,6 +64,7 @@ data Lexeme
|
|||
= Blank String
|
||||
| Tok String
|
||||
| QTok String String -- unquoted quoted
|
||||
| DQTok String String -- unquoted quoted
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
blank :: Lexer Lexeme
|
||||
|
|
@ -86,14 +87,15 @@ qtok = do
|
|||
z <- string "'"
|
||||
return $ QTok y (x ++ y ++ z)
|
||||
|
||||
cmt :: Lexer Lexeme
|
||||
cmt =
|
||||
Blank . concat <$>
|
||||
sequence
|
||||
[string "%", many $ satisfy (/= '\n'), choice [string "\n", "" <$ eof]]
|
||||
dqtok :: Lexer Lexeme
|
||||
dqtok = do
|
||||
x <- string "\""
|
||||
y <- many $ satisfy (/= '\"') -- TODO actual escaping
|
||||
z <- string "\""
|
||||
return $ DQTok y (x ++ y ++ z)
|
||||
|
||||
lexeme :: Lexer Lexeme
|
||||
lexeme = choice [blank, tok, qtok, cmt]
|
||||
lexeme = choice [blank, tok, qtok, dqtok]
|
||||
|
||||
lexPrlg :: Lexer [Lexeme]
|
||||
lexPrlg = many lexeme <* (many blank >> eof)
|
||||
|
|
@ -101,6 +103,7 @@ lexPrlg = many lexeme <* (many blank >> eof)
|
|||
showTok (Blank x) = x
|
||||
showTok (Tok x) = x
|
||||
showTok (QTok _ x) = x
|
||||
showTok (DQTok _ x) = x
|
||||
|
||||
instance VisualStream [Lexeme] where
|
||||
showTokens _ (a :| b) = concatMap showTok (a : b)
|
||||
|
|
@ -146,9 +149,9 @@ instance TraversableStream [Lexeme] where
|
|||
|
||||
data PAST
|
||||
= Call String [[PAST]]
|
||||
| Seq [PAST]
|
||||
| Group [PAST]
|
||||
| List [[PAST]] (Maybe [PAST])
|
||||
| Literal String
|
||||
| Literal Lexeme
|
||||
deriving (Show, Eq)
|
||||
|
||||
type Parser = Parsec Void [Lexeme]
|
||||
|
|
@ -165,6 +168,7 @@ isNormalTokStr = (`notElem` [".", "[", "]", "(", "|", ")", "{", "}"])
|
|||
isNormalTok :: Lexeme -> Bool
|
||||
isNormalTok (Tok x) = isNormalTokStr x
|
||||
isNormalTok (QTok _ _) = True
|
||||
isNormalTok (DQTok _ _) = True
|
||||
isNormalTok _ = False
|
||||
|
||||
isCallTok :: Lexeme -> Bool
|
||||
|
|
@ -174,34 +178,35 @@ isCallTok _ = True
|
|||
|
||||
unTok (Tok t) = t
|
||||
unTok (QTok t _) = t
|
||||
unTok (DQTok t _) = t
|
||||
|
||||
literal :: Parser PAST
|
||||
literal =
|
||||
Literal . unTok <$>
|
||||
Literal <$>
|
||||
free
|
||||
(choice
|
||||
[ satisfy isCallTok <* notFollowedBy (choice [lParen, lBrace])
|
||||
, 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
|
||||
fn <- fmod . unTok <$> satisfy isCallTok -- not free
|
||||
(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
|
||||
free lBracket
|
||||
(List [] Nothing <$ free rBracket) <|> do
|
||||
items <- splitOn [Literal ","] <$> some seqItem
|
||||
items <- splitOn [Literal (Tok ",")] <$> some seqItem
|
||||
(List items Nothing <$ free rBracket) <|>
|
||||
(List items . Just <$> (free listTail *> some seqItem <* free rBracket))
|
||||
|
||||
|
|
@ -237,7 +242,7 @@ lBrace = simpleTok "{"
|
|||
rBrace = simpleTok "}"
|
||||
|
||||
clause :: Parser PAST
|
||||
clause = Seq <$> some (free seqItem) <* free period
|
||||
clause = Group <$> some (free seqItem) <* free period
|
||||
|
||||
parsePrlg :: Parser [PAST]
|
||||
parsePrlg = ws *> many clause <* eof
|
||||
|
|
@ -246,6 +251,11 @@ type ShuntError = String
|
|||
|
||||
type ShuntResult = Either ShuntError PrlgStr
|
||||
|
||||
data PrlgStr
|
||||
= CallS String [PrlgStr]
|
||||
| LiteralS Lexeme
|
||||
deriving (Show)
|
||||
|
||||
err :: ShuntError -> Either ShuntError a
|
||||
err = Left
|
||||
|
||||
|
|
@ -254,8 +264,10 @@ shuntPrlg ot = shuntPrlg' (("", Op 0 $ Infix Y X) : ot)
|
|||
|
||||
shuntPrlg' :: Ops -> PAST -> ShuntResult
|
||||
shuntPrlg' ot (List hs t) =
|
||||
ListS <$> traverse (shunt ot) hs <*> traverse (shunt ot) t
|
||||
shuntPrlg' ot (Seq ss) = shunt ot ss
|
||||
foldr (\x y -> CallS "[]" [x, y]) <$>
|
||||
(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 (Call fn ss) = CallS fn <$> traverse (shunt ot) ss
|
||||
|
||||
|
|
@ -296,13 +308,13 @@ shunt optable = start
|
|||
(ops', vs') <- pushInfix ops vs x
|
||||
wo ops' vs' xs
|
||||
, do getOperand x
|
||||
ho ops vs (Literal "" : xs') -- app (see below)
|
||||
ho ops vs (Literal (Tok "") : xs') -- app (see below)
|
||||
, do getPrefix x
|
||||
ho ops vs (Literal "" : xs') -- also app!
|
||||
ho ops vs (Literal (Tok "") : xs') -- also app!
|
||||
, err "expected infix or suffix operator"
|
||||
]
|
||||
{- 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 -}
|
||||
ho [] [res] [] = pure res
|
||||
ho ops vs [] = do
|
||||
|
|
@ -319,11 +331,14 @@ shunt optable = start
|
|||
{- Operator checks -}
|
||||
uniq [x] = pure x
|
||||
uniq _ = err "ambiguous operator"
|
||||
getPrefix x = uniq [op | (s, op@(Op _ (Prefix _))) <- optable, s == x]
|
||||
getSuffix x = uniq [op | (s, op@(Op _ (Suffix _))) <- optable, s == x]
|
||||
getInfix x = uniq [op | (s, op@(Op _ (Infix _ _))) <- optable, s == x]
|
||||
getOperand x
|
||||
| null [op | (s, op) <- optable, s == x] = pure ()
|
||||
getPrefix t =
|
||||
uniq [op | Tok x <- [t], (s, op@(Op _ (Prefix _))) <- optable, s == x]
|
||||
getSuffix t =
|
||||
uniq [op | Tok x <- [t], (s, op@(Op _ (Suffix _))) <- optable, s == x]
|
||||
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"
|
||||
{- actual pushery -}
|
||||
canPush :: Ops -> Op -> Either ShuntError Bool
|
||||
|
|
@ -371,7 +386,7 @@ shunt optable = start
|
|||
shunt1 ops vs x op = do
|
||||
cp <- canPush ops op
|
||||
if cp
|
||||
then pure ((x, op) : ops, vs)
|
||||
then pure ((unTok x, op) : ops, vs)
|
||||
else do
|
||||
(ops', vs') <- pop ops vs
|
||||
shunt1 ops' vs' x op --prefix would behave differently here but that's impossible by canPush
|
||||
|
|
|
|||
26
prlg.cabal
26
prlg.cabal
|
|
@ -28,11 +28,33 @@ executable prlg
|
|||
main-is: Main.hs
|
||||
|
||||
-- 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.
|
||||
-- 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
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wunused-imports
|
||||
|
|
|
|||
Loading…
Reference in a new issue