diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Builtins.hs | 36 | ||||
| -rw-r--r-- | app/Compiler.hs | 38 | ||||
| -rw-r--r-- | app/Frontend.hs | 4 | ||||
| -rw-r--r-- | app/Load.hs | 9 |
4 files changed, 41 insertions, 46 deletions
diff --git a/app/Builtins.hs b/app/Builtins.hs index 7996926..60653df 100644 --- a/app/Builtins.hs +++ b/app/Builtins.hs @@ -96,11 +96,13 @@ assertFact :: (Code -> Id -> PrlgEnv ()) -> InterpFn assertFact addClause = withArgs [0] $ \[arg] -> do heap <- use (cur . heap) - case Co.compileGoal . Co.squashVars <$> - Co.heapStructPrlgInt Nothing heap arg of - Just (U (Struct s):head) -> do - addClause (head ++ [Done]) s - continue + case Co.heapStructPrlgInt Nothing heap arg of + Just x -> do + case Co.compileGoal $ Co.squashVars x of + Right (U (Struct s):head) -> do + addClause (head ++ [Done]) s + continue + Left err -> prlgError err _ -> prlgError "assert fact failure" assertRule :: (Code -> Id -> PrlgEnv ()) -> InterpFn @@ -108,16 +110,13 @@ assertRule addClause = withArgs [0, 1] $ \args -> do scope <- use (cur . hvar) heap <- use (cur . heap) - comma <- findAtom "," - semi <- findAtom ";" - cut <- findAtom "!" + [comma, semi, cut] <- traverse findAtom [",", ";", "!"] case Co.squashVars . IR.CallI 0 <$> traverse (Co.heapStructPrlgInt Nothing heap) args of Just (IR.CallI 0 [hs, gs]) -> - let (U (Struct s):cs) = - Co.compileGoal hs ++ Co.compileGoals comma semi cut gs - in do addClause cs s - continue + case (++) <$> Co.compileGoal hs <*> Co.compileGoals comma semi cut gs of + Right (U (Struct s):cs) -> addClause cs s >> continue + Left err -> prlgError err _ -> prlgError "assert clause failure" retractall :: InterpFn @@ -139,11 +138,14 @@ exec' fgol = comma <- findAtom "," semi <- findAtom ";" cut <- findAtom "!" - zoom cur $ do - hvar .= M.empty - hed .= Co.compileGoals comma semi cut gs - gol %= fgol - continue + case Co.compileGoals comma semi cut gs of + Right nhed -> do + zoom cur $ do + hvar .= M.empty + hed .= nhed + gol %= fgol + continue + Left err -> prlgError err _ -> prlgError "bad goal" call :: InterpFn diff --git a/app/Compiler.hs b/app/Compiler.hs index 693bf99..0886533 100644 --- a/app/Compiler.hs +++ b/app/Compiler.hs @@ -1,6 +1,7 @@ module Compiler where import Constant +import Control.Monad import Data.Char (isUpper) import qualified Data.Map as M @@ -45,28 +46,28 @@ squashVars x = [(idx, VarI idx') | ((idx, n), idx') <- zip occurs [1 ..], n > 1] in renumVars (m' M.!?) x -squashChoices :: [Code] -> Code +squashChoices :: [Code] -> Either String Code squashChoices = out . concatMap go where go [Choices cs] = cs go x = [x] - out [] = error "choice compilation" - out [x] = x - out xs = [Choices xs] + out [] = Left "goal compilation has no choices?" + out [x] = pure x + out xs = pure [Choices xs] -compileGoals :: Int -> Int -> Int -> PrlgInt -> Code -compileGoals andop orop cut = (++ [Done]) . go' +compileGoals :: Int -> Int -> Int -> PrlgInt -> Either String Code +compileGoals andop orop cut = fmap (++ [Done]) . go' where - go' = go . struct2goal + go' = struct2goal >=> go go p@(CallI x args@[_, _]) - | x == andop = concatMap go' args - | x == orop = squashChoices $ map go' args + | x == andop = concat <$> traverse go' args + | x == orop = traverse go' args >>= squashChoices go p@(CallI x []) - | x == cut = [Cut] + | x == cut = pure [Cut] go x = compileGoal x -compileGoal :: PrlgInt -> Code -compileGoal = compileArg . struct2goal +compileGoal :: PrlgInt -> Either String Code +compileGoal = fmap compileArg . struct2goal compileArg :: PrlgInt -> Code compileArg (CallI i args) = @@ -88,12 +89,7 @@ heapStructPrlgInt heaperr heap ref = heapStruct atom struct hrec heap ref | r == ref = pure $ VarI r | otherwise = heaperr --- TODO check if this is used -goal2struct :: PrlgInt -> PrlgInt -goal2struct (CallI s []) = ConstI (Atom s) -goal2struct x = x - -struct2goal :: PrlgInt -> PrlgInt -struct2goal (ConstI (Atom s)) = CallI s [] -struct2goal call@(CallI _ _) = call -struct2goal _ = error "TODO." +struct2goal :: PrlgInt -> Either String PrlgInt +struct2goal (ConstI (Atom s)) = pure $ CallI s [] +struct2goal call@(CallI _ _) = pure call +struct2goal x = Left $ "cannot compile goal: " ++ show x diff --git a/app/Frontend.hs b/app/Frontend.hs index e049365..ee7c9ef 100644 --- a/app/Frontend.hs +++ b/app/Frontend.hs @@ -33,8 +33,8 @@ handleError m = do processCmd precompileHook ast' = do ast <- shunt ast' - code <- lift $ intern ast >>= precompileHook >>= compile - lift (I.prove code) >>= except + source <- lift $ intern ast >>= precompileHook + compile source >>= lift . I.prove >>= except interpreterStart :: PrlgEnv () interpreterStart = do diff --git a/app/Load.hs b/app/Load.hs index 5a482fd..440c160 100644 --- a/app/Load.hs +++ b/app/Load.hs @@ -31,16 +31,13 @@ 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 prlgi) -compile :: IR.PrlgInt -> PrlgEnv Code +compile :: IR.PrlgInt -> ExceptT String PrlgEnv Code compile prlgv = do - comma <- findAtom "," - semi <- findAtom ";" - cut <- findAtom "!" - return $ C.compileGoals comma semi cut prlgv + [comma, semi, cut] <- lift $ traverse findAtom [",", ";", "!"] + except $ C.compileGoals comma semi cut prlgv expansion :: (Int -> IR.PrlgInt -> IR.PrlgInt) |