75 lines
2 KiB
Haskell
75 lines
2 KiB
Haskell
module Compiler where
|
|
|
|
import Data.Char (isUpper)
|
|
import Data.Containers.ListUtils (nubOrd)
|
|
import Data.List
|
|
import Interpreter (Code, Datum(..), Id(..), Instr(..), StrTable, strtablize)
|
|
|
|
data PrlgStr
|
|
= CallS String [PrlgStr]
|
|
| LiteralS String
|
|
deriving (Show)
|
|
|
|
data PrlgInt
|
|
= CallI Id [PrlgInt]
|
|
| LiteralI Int
|
|
| VarI Int Int
|
|
| VoidI
|
|
deriving (Show)
|
|
|
|
varname :: String -> Bool
|
|
varname ('_':_) = True
|
|
varname (c:_) = isUpper c
|
|
varname _ = False
|
|
|
|
varnames :: PrlgStr -> [String]
|
|
varnames (CallS _ xs) = nubOrd $ concatMap varnames xs
|
|
varnames (LiteralS x)
|
|
| varname x = [x]
|
|
| otherwise = []
|
|
|
|
strtablizePrlg :: [String] -> StrTable -> PrlgStr -> (StrTable, PrlgInt)
|
|
strtablizePrlg stab = go
|
|
where
|
|
go t (LiteralS str)
|
|
| str == "_" = (t, VoidI)
|
|
| Just idx <- elemIndex str stab = VarI idx <$> strtablize t str
|
|
| otherwise = LiteralI <$> strtablize t str
|
|
go t (CallS str ps) =
|
|
let (t', i) = strtablize t str
|
|
in CallI (Id i $ length ps) <$> mapAccumL go t' ps
|
|
|
|
compileGoals :: Id -> PrlgInt -> [Code]
|
|
compileGoals andop = go
|
|
where
|
|
go p@(CallI x args)
|
|
| x == andop = concatMap go args
|
|
go x = [compileGoal x]
|
|
|
|
compileGoal :: PrlgInt -> Code
|
|
compileGoal (LiteralI x) = [U (Struct $ Id x 0)]
|
|
compileGoal x = compileArg x
|
|
|
|
compileArg :: PrlgInt -> Code
|
|
compileArg (CallI x args) = U (Struct x) : concatMap compileArg args
|
|
compileArg (LiteralI x) = [U (Atom x)]
|
|
compileArg (VarI x _) = [U (LocalRef x)]
|
|
compileArg VoidI = [U VoidRef]
|
|
|
|
seqGoals :: [Code] -> Code
|
|
seqGoals [] = [NoGoal]
|
|
seqGoals [[Cut]] = [Cut, NoGoal]
|
|
seqGoals [x] = [Goal] ++ x ++ [LastCall]
|
|
seqGoals [x, [Cut]] = [Goal] ++ x ++ [LastCall, Cut]
|
|
seqGoals (x:xs) = [Goal] ++ x ++ [Call] ++ seqGoals xs
|
|
|
|
compileClause :: Id -> Id -> PrlgInt -> Code
|
|
compileClause proveop andop = go
|
|
where
|
|
go :: PrlgInt -> Code
|
|
go h@(CallI x args)
|
|
| x == proveop
|
|
, [head, goals] <- args =
|
|
compileGoal head ++ seqGoals (compileGoals andop goals)
|
|
| otherwise = compileGoal h ++ seqGoals []
|