summaryrefslogtreecommitdiff
path: root/Text/CTPL.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Text/CTPL.hs')
-rw-r--r--Text/CTPL.hs105
1 files changed, 80 insertions, 25 deletions
diff --git a/Text/CTPL.hs b/Text/CTPL.hs
index 6ca1f66..34f6869 100644
--- a/Text/CTPL.hs
+++ b/Text/CTPL.hs
@@ -1,5 +1,8 @@
+-- | Compiler for CTPL, generating CTPL0 code.
+
module Text.CTPL where
+import Control.Applicative hiding (many, Const, some)
import Control.Monad
import Data.Char
import Data.Monoid
@@ -7,10 +10,35 @@ import Text.Chatty.Parser
import Text.Chatty.Parser.Carrier
import qualified Text.CTPL0 as Null
-data Procedure = Procedure { procName :: String, procInstr :: Instruction, procAddr :: Int }
-data CTPLState = CTPLState { definedProcs :: [Procedure] }
-data Exec a = Succ a | NoSuchProc String | SyntaxFault deriving Show
-data CTPL a = CTPL { runCTPL :: CTPLState -> Exec (a, CTPLState, String -> String) }
+-- | Compiler configuration.
+data CCConfig = CCConfig {
+ ccTarget :: CCTarget -- ^ Target VM
+ }
+
+-- | Target VM
+data CCTarget = OldVM -- ^ produce output compatible with the old VM (Text.CTPL0)
+ | NewVM -- ^ produce output for the new VM only (Text.CTPL0n)
+
+-- | A parsed CTPL procedure.
+data Procedure = Procedure {
+ procName :: String, -- ^ Name of the procedure
+ procInstr :: Instruction, -- ^ Instructions
+ procAddr :: Int -- ^ Address (if already known)
+ }
+
+-- | Compiler state record
+data CTPLState = CTPLState {
+ definedProcs :: [Procedure] -- ^ Procedure already encountered
+ }
+
+-- | Monad displaying success or failure.
+data Exec a = Succ a -- ^ Compilation succeeded :)
+ | NoSuchProc String -- ^ Nope. Encountered a call to a procedure I can`t find.
+ | SyntaxFault -- ^ Nope. Syntax fault. I have no idea what you`re trying to tell me.
+ deriving Show
+
+-- | The compiler's execution monad. Behaves like a 'StateT CTPLState' wrapped around a 'ReaderT CCConfig' wrapped around a 'WriterT String' wrapped around the 'Exec' monad.
+data CTPL a = CTPL { runCTPL :: CTPLState -> CCConfig -> Exec (a, CTPLState, String -> String) }
instance Monad Exec where
return a = Succ a
@@ -18,37 +46,61 @@ instance Monad Exec where
(NoSuchProc s) >>= f = NoSuchProc s
SyntaxFault >>= f = SyntaxFault
+instance Applicative Exec where
+ pure = return
+ (<*>) = ap
+
+instance Functor Exec where
+ fmap = liftM
+
instance Monad CTPL where
- return a = CTPL $ \s -> return (a, s, id)
- m >>= f = CTPL $ \s -> do
- (a', s', f') <- runCTPL m s
- (a'', s'', f'') <- runCTPL (f a') s'
+ return a = CTPL $ \s cfg -> return (a, s, id)
+ m >>= f = CTPL $ \s cfg -> do
+ (a', s', f') <- runCTPL m s cfg
+ (a'', s'', f'') <- runCTPL (f a') s' cfg
return (a'', s'', f' . f'')
+instance Applicative CTPL where
+ pure = return
+ (<*>) = ap
+
+instance Functor CTPL where
+ fmap = liftM
+
+-- | Predefined compiler configuration. Generated code is compatible to both VMs.
+oldConfig :: CCConfig
+oldConfig = CCConfig{ccTarget=OldVM}
+
+-- | Predefined compiler configuration. Generated code is compatible to the new VM only.
+newConfig :: CCConfig
+newConfig = CCConfig{ccTarget=NewVM}
+
+-- | Gets the carried 'CTPLState' and runs a function on it.
getState :: (CTPLState -> a) -> CTPL a
-getState f = CTPL $ \s -> return (f s, s, id)
+getState f = CTPL $ \s cfg -> return (f s, s, id)
+-- | RUns a function on the carried 'CTPLState'.
modState :: (CTPLState -> CTPLState) -> CTPL ()
-modState f = CTPL $ \s -> return ((), f s, id)
+modState f = CTPL $ \s cfg -> return ((), f s, id)
emit :: String -> CTPL ()
-emit str = CTPL $ \s -> return ((), s, (str++))
+emit str = CTPL $ \s cfg -> return ((), s, (str++))
getProc :: String -> (Procedure -> a) -> CTPL a
getProc nm f = do
ps <- getState definedProcs
case filter (\p -> procName p == nm) ps of
- [] -> CTPL $ \_ -> NoSuchProc nm
+ [] -> CTPL $ \_ _ -> NoSuchProc nm
[p] -> return (f p)
catchEmission :: CTPL () -> CTPL String
-catchEmission m = CTPL $ \s -> do
- (_,s',f') <- runCTPL m s
+catchEmission m = CTPL $ \s cfg -> do
+ (_,s',f') <- runCTPL m s cfg
return (f' [], s', id)
discardEmission :: CTPL a -> CTPL a
-discardEmission m = CTPL $ \s -> do
- (a,s',_) <- runCTPL m s
+discardEmission m = CTPL $ \s cfg -> do
+ (a,s',_) <- runCTPL m s cfg
return (a, s', id)
data NumSource = AX Int | CK0 Int | Buf NumSource Int | Const Int | Len Int | CP Int deriving Show
@@ -290,10 +342,10 @@ dumpCond cond jumper = case cond of
-- Cd[ldbuf]Cmkj|q#!t
EqCh d chs -> emit "Cd" >> dumpInstr (SetCK0 d) >> emit "Cmk" >> emit jumper >> emit (foldr q "!t" chs) >> return "" where q a b = "|q"++[a]++b
-compile :: [Procedure] -> Instruction -> Exec String
-compile ps main = do
+compile :: [Procedure] -> Instruction -> CCConfig -> Exec String
+compile ps main cfg = do
let s0 = CTPLState (ps++[Procedure [] main 0])
- (_, _, out) <- flip runCTPL s0 $ do
+ (_, _, out) <- runCTPL (do
ps <- getState definedProcs
ps' <- allocProcs 7 ps
modState $ \s -> s{definedProcs=ps'}
@@ -301,7 +353,7 @@ compile ps main = do
emit "+"
dumpAddr amain
emit "jt"
- forM_ ps' $ \p -> dumpInstr $ procInstr p
+ forM_ ps' $ \p -> dumpInstr $ procInstr p) s0 cfg
return $ out []
multiParse :: ChParser m => m ([Procedure], [Instruction])
@@ -549,15 +601,18 @@ parseCond = parseNot ??? parseIsLower ??? parseEq ??? parseEqCh ??? parseLt ???
return $ EqCh ns chs
parse :: String -> [] ([Procedure], [Instruction])
-parse s = runCarrierT s multiParse
+parse s = runCarrierT s $ do
+ p <- multiParse
+ many white
+ return p
-compileCTPL :: String -> Exec String
-compileCTPL s = case parse s of
+compileCTPL :: String -> CCConfig -> Exec String
+compileCTPL s cfg = case parse s of
[] -> SyntaxFault
- (ps, is):_ -> compile ps (Compound is)
+ (ps, is):_ -> compile ps (Compound is) cfg
evalCTPL :: String -> String -> Int -> Null.Exec String
evalCTPL program buffer limit =
- case compileCTPL program of
+ case compileCTPL program oldConfig of
Succ bc -> Null.evalCTPL0 bc buffer limit
_ -> Null.SynViol