From 98c40f4bf8849f5cdd3d3c49123bc911b8fa42e1 Mon Sep 17 00:00:00 2001 From: Mirek Kratochvil Date: Sun, 5 Mar 2023 21:34:20 +0100 Subject: [PATCH] strings and a few other small nice changes --- app/Builtins.hs | 130 +++++++++++++++++++++++++-------------------- app/Code.hs | 23 +++++--- app/Compiler.hs | 40 ++++++-------- app/Env.hs | 12 ++--- app/Heap.hs | 1 - app/IR.hs | 35 ++++-------- app/Interpreter.hs | 14 +++-- app/Load.hs | 13 ++--- app/Parser.hs | 75 +++++++++++++++----------- prlg.cabal | 30 +++++++++-- 10 files changed, 200 insertions(+), 173 deletions(-) diff --git a/app/Builtins.hs b/app/Builtins.hs index 8df703c..7996926 100644 --- a/app/Builtins.hs +++ b/app/Builtins.hs @@ -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,30 +501,30 @@ addPrelude = do ] ("expand_" ++ q) 2 - expandCode "load" - expandCode "query" + 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" (+) - add2IntOp "sub" (-) - add1IntOp "neg" negate - add1IntOp "abs" abs - add2IntOp "mul" (*) - add2IntOp "div" div - add2IntOp "mod" mod - add2IntOp "bitand" (.&.) - add2IntOp "bitor" (.|.) - add2IntOp "bitxor" xor - add2IntOp "shl" shiftL - add2IntOp "shr" shiftR - add1IntPred "zero" (== 0) - add2IntPred "eq" (==) - add2IntPred "lt" (<) - add2IntPred "leq" (<=) - add2IntPred "neq" (/=) + in do add2IntOp "add" (+) + add2IntOp "sub" (-) + add1IntOp "neg" negate + add1IntOp "abs" abs + add2IntOp "mul" (*) + add2IntOp "div" div + add2IntOp "mod" mod + add2IntOp "bitand" (.&.) + add2IntOp "bitor" (.|.) + add2IntOp "bitxor" xor + add2IntOp "shl" shiftL + add2IntOp "shr" shiftR + add1IntPred "zero" (== 0) + add2IntPred "eq" (==) + add2IntPred "lt" (<) + add2IntPred "leq" (<=) + add2IntPred "neq" (/=) {- query tools -} addBi printLocals "print_locals" 0 addBi promptRetry' "prompt_retry" 0 diff --git a/app/Code.hs b/app/Code.hs index b60ab66..6efa5b9 100644 --- a/app/Code.hs +++ b/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 diff --git a/app/Compiler.hs b/app/Compiler.hs index f77a969..693bf99 100644 --- a/app/Compiler.hs +++ b/app/Compiler.hs @@ -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." diff --git a/app/Env.hs b/app/Env.hs index 03a7ce8..0b648f8 100644 --- a/app/Env.hs +++ b/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 diff --git a/app/Heap.hs b/app/Heap.hs index 1daa52f..99135a2 100644 --- a/app/Heap.hs +++ b/app/Heap.hs @@ -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 diff --git a/app/IR.hs b/app/IR.hs index fef193b..d7345e5 100644 --- a/app/IR.hs +++ b/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 diff --git a/app/Interpreter.hs b/app/Interpreter.hs index 2ad0118..440b6fa 100644 --- a/app/Interpreter.hs +++ b/app/Interpreter.hs @@ -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 diff --git a/app/Load.hs b/app/Load.hs index 9fb4c94..5a482fd 100644 --- a/app/Load.hs +++ b/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" diff --git a/app/Parser.hs b/app/Parser.hs index e6b7a7a..9d11cc8 100644 --- a/app/Parser.hs +++ b/app/Parser.hs @@ -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 diff --git a/prlg.cabal b/prlg.cabal index 693ade9..92001b2 100644 --- a/prlg.cabal +++ b/prlg.cabal @@ -21,18 +21,40 @@ maintainer: exa.exa@gmail.com -- category: extra-source-files: CHANGELOG.md -data-dir: inst -data-files: *.pl +data-dir: inst +data-files: *.pl 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