diff --git a/src/Text/Twine.hs b/src/Text/Twine.hs --- a/src/Text/Twine.hs +++ b/src/Text/Twine.hs @@ -1,17 +1,17 @@ -module Text.Twine (module Text.Twine.Parser - ,module Text.Twine.Interpreter - ,module Text.Twine.Interpreter.Context - ,module Text.Twine.Interpreter.FancyContext - ,module Text.Twine.Interpreter.ContextWriter - ,evalTemplate) +module Text.Twine ( + module Text.Twine.Parser + ,module Text.Twine.Interpreter + ,module Text.Twine.Interpreter.Interface + ,module Text.Twine.Interpreter.ContextWriter + , TwineElement + ,evalTemplate) where -import Text.Twine.Parser -import Text.Twine.Interpreter.Types -import Text.Twine.Interpreter.Context -import Text.Twine.Interpreter.FancyContext -import Text.Twine.Interpreter.ContextWriter import Text.Twine.Interpreter +import Text.Twine.Interpreter.Interface +import Text.Twine.Interpreter.ContextWriter +import Text.Twine.Interpreter.Types +import Text.Twine.Parser evalTemplate template context = do templ <- loadTemplateFromFile template diff --git a/src/Text/Twine/Interpreter.hs b/src/Text/Twine/Interpreter.hs --- a/src/Text/Twine/Interpreter.hs +++ b/src/Text/Twine/Interpreter.hs @@ -1,38 +1,33 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module Text.Twine.Interpreter (runEval) where ---import Text.Twine - +import Control.Monad.Identity import Control.Monad.State import Control.Monad.Writer -import Control.Monad.Identity - -import Text.Twine.Interpreter.Types -import Text.Twine.Interpreter.Context -import Text.Twine.Interpreter.FancyContext +import Data.ByteString.Char8 (ByteString,pack,unpack) +import Debug.Trace import Text.Twine.Interpreter.Builtins +import Text.Twine.Interpreter.Interface +import Text.Twine.Interpreter.Types import Text.Twine.Parser.Types -import Data.ByteString.Char8 (ByteString,pack,unpack) import qualified Data.ByteString.Char8 as C -import Debug.Trace import qualified Data.Map as M -type Stack m a = StateT (ContextState m) (WriterT [String] m) a +-- TODO: Most of the interpreter is all wrong, and there is no error +-- checking. Eventually this all needs to be fixed up. --- simpleContext +type Stack m a = StateT (ContextState m) (WriterT [String] m) a foldCX :: (Monad m) => [TwineElement m] -> TwineElement m foldCX = foldl (<+>) emptyContext --- Context Writer Monad -- - mergeCXP (TwineObjectList a) (TwineObjectList b) = TwineObjectList (a ++ b) mergeCXP (TwineList a) (TwineList b) = TwineList (a ++ b) mergeCXP (TwineObject a) x = TwineObjectList [a] `mergeCXP` x mergeCXP x (TwineObject a) = x `mergeCXP` TwineObjectList [a] mergeCXP a b = error $ "Cannot merge " ++ show a ++ " and " ++ show b -(<+>) = mergeCXP +(<+>) = mergeCXP runStack run state = runWriterT (runStateT run state) @@ -73,7 +68,7 @@ eval (Assign k e) = debug ("evaluating assign " ++ show k ++ " = " ++ show e) $ do ee <- evalExpr e st <- getCX - putCX (bind [(k,ee)] <+> st) + putCX (bind (M.fromList [(k,ee)]) <+> st) return (C.pack "") eval (Cond e bls) = do @@ -90,19 +85,23 @@ case ee of TwineNull -> return (C.pack "") a -> runLoop a - where runLoop (TwineList ls) = fmap (C.concat) $ mapM inner ls - - runLoop (TwineObjectList x) = do - it <- lift2 $ getIterable (head x) - runLoop (TwineList it) - - runLoop (TwineObject x) = do - it <- lift2 $ getIterable x - runLoop (TwineList it) - - runLoop x = error $ "Not iterable: " ++ show x - inner v = do cx <- getCX - lift2 $ runEval bls (bind [(as,v)] <+> cx) + where + --runLoop :: (Monad m) => TwineElement m -> m C.ByteString + runLoop (TwineList ls) = fmap (C.concat) $ mapM inner ls + + runLoop (TwineObjectList x) = do + it <- lift2 $ getIterable (head x) + runLoop (TwineList it) + + runLoop (TwineObject x) = do + it <- lift2 $ getIterable x + runLoop (TwineList it) + + runLoop x = error $ "Not iterable: " ++ show x + + inner v = do + cx <- getCX + lift2 $ runEval bls (bind (M.fromList [(as,v)]) <+> cx) eval x = error $ "Cannot eval: '" ++ (show x) ++ "'" diff --git a/src/Text/Twine/Interpreter/Builtins.hs b/src/Text/Twine/Interpreter/Builtins.hs --- a/src/Text/Twine/Interpreter/Builtins.hs +++ b/src/Text/Twine/Interpreter/Builtins.hs @@ -4,12 +4,12 @@ import Data.Char import Data.List import Text.Twine.Interpreter.Types -import Text.Twine.Interpreter.Context +import Text.Twine.Interpreter.Interface import Control.Exception (assert) import qualified Data.ByteString.Char8 as C import qualified Data.Map as M -myNot [TwineBool b] = return . bind $ not b +myNot [b] = unbind b >>= return . bind . not builtins :: (Monad m) => M.Map C.ByteString (TwineElement m) -builtins = M.fromList [("not", TwineFunction myNot)] +builtins = M.fromList [("not", method myNot)] diff --git a/src/Text/Twine/Interpreter/Context.hs b/src/Text/Twine/Interpreter/Context.hs deleted file mode 100644 --- a/src/Text/Twine/Interpreter/Context.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-#LANGUAGE MultiParamTypeClasses - , TypeSynonymInstances - , FlexibleInstances - , FlexibleContexts - , NoMonomorphismRestriction - , OverlappingInstances - , OverloadedStrings - , UndecidableInstances - , FunctionalDependencies - #-} - -module Text.Twine.Interpreter.Context (emptyContext, TemplateInterface (..)) where - -import Data.ByteString.Char8 (ByteString) -import Data.Maybe -import Data.Monoid -import Text.Twine.Interpreter.Types -import qualified Data.ByteString.Char8 as C -import Control.Monad.Writer -import qualified Data.Map as M - -class (Monad m) => TemplateInterface m a | a -> m where - property :: ByteString -> a -> m (TwineElement m) - makeIterable :: a -> m [TwineElement m] - makeString :: a -> m String - bind :: (TemplateInterface m a) => a -> TwineElement m - - property _ _ = return TwineNull - makeIterable _ = return [] - makeString _ = return "" - bind a = TwineObject $ Context { - getContext = (flip property a), - getIterable = makeIterable a, - getString = makeString a - } - - -instance (Monad m) => TemplateInterface m (TwineElement m) where - bind = id - makeString = return . show - -instance (Monad m) => TemplateInterface m ([TwineElement m] -> m (TwineElement m)) where - bind = TwineFunction - -instance (Monad m) => TemplateInterface m EmptyContext - -instance (Monad m, TemplateInterface m a) => TemplateInterface m (Maybe a) where - bind (Just a) = bind a - bind Nothing = TwineNull - -instance (Monad m) => TemplateInterface m [(ByteString,TwineElement m)] where - property k = return . fromMaybe TwineNull . lookup k - -instance (Monad m) => TemplateInterface m String where - bind = TwineString . C.pack - -instance (Monad m) => TemplateInterface m ByteString where - bind a = TwineString a - -instance (Monad m) => TemplateInterface m Bool where - bind = TwineBool - -instance (Monad m) => TemplateInterface m (M.Map ByteString (TwineElement m)) where - property k = return . fromMaybe (TwineNull) . M.lookup k - -emptyContext :: (Monad m) => TwineElement m -emptyContext = bind EmptyContext - diff --git a/src/Text/Twine/Interpreter/ContextWriter.hs b/src/Text/Twine/Interpreter/ContextWriter.hs --- a/src/Text/Twine/Interpreter/ContextWriter.hs +++ b/src/Text/Twine/Interpreter/ContextWriter.hs @@ -13,13 +13,13 @@ import Data.Maybe import Data.Monoid import Text.Twine.Interpreter.Types -import Text.Twine.Interpreter.Context -import Text.Twine.Interpreter.FancyContext +import Text.Twine.Interpreter.Interface import Text.Twine.Interpreter.Builtins import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as C import Control.Monad.Writer import Data.Map (Map) +import Data.Convertible import qualified Data.Map as M type TwineObjectper m = Map ByteString (TwineElement m) @@ -30,4 +30,5 @@ mp <- execWriterT cw return $ bind (mp `M.union` builtins) +--(=:) :: (MonadWriter (Map ByteString (TwineElement m)) m, Convertible a (TwineElement m)) => String -> a -> m () k =: v = tell $ M.fromList [(C.pack k, bind v)] diff --git a/src/Text/Twine/Interpreter/FancyContext.hs b/src/Text/Twine/Interpreter/FancyContext.hs deleted file mode 100644 --- a/src/Text/Twine/Interpreter/FancyContext.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-#LANGUAGE MultiParamTypeClasses - , TypeSynonymInstances - , FlexibleInstances - , FlexibleContexts - , NoMonomorphismRestriction - , OverlappingInstances - , OverloadedStrings - , UndecidableInstances - #-} - - -module Text.Twine.Interpreter.FancyContext where -import Text.Twine.Interpreter.Types -import Text.Twine.Interpreter.Context - -instance (TemplateInterface m a) => TemplateInterface m [a] where - bind = bind . CXListLike . map bind - -instance (Monad m) => TemplateInterface m (CXListLike m) where - property "length" = mbind . length . unCXListLike - property "head" = mbind . head . unCXListLike - property "tail" = mbind . tail . unCXListLike - property "init" = mbind . init . unCXListLike - property "last" = mbind . last . unCXListLike - property "item" = \x -> return $ TwineFunction (\[n] -> do - i <- cxToInteger n - mbind (unCXListLike x !! fromIntegral i)) - - property "take" = \x -> return $ TwineFunction (\[n] -> do - i <- cxToInteger n - mbind . take (fromIntegral i) $ unCXListLike x) - - property "drop" = \x -> return $ TwineFunction (\[n] -> do - i <- cxToInteger n - mbind . drop (fromIntegral i) $ unCXListLike x) - - makeIterable = return . unCXListLike - makeString = \_-> return "" - ------------------------------------------------------------------------- - -instance (Monad m) => TemplateInterface m Int where - bind = bind . CXInteger . fromIntegral - -instance (Monad m) => TemplateInterface m Integer where - bind = bind . CXInteger - -instance (Monad m) => TemplateInterface m CXInteger where - makeString = return . show . unCXInteger - property "toInteger" = return . TwineInteger . unCXInteger - property "even?" = mbind . even . unCXInteger - property "odd?" = mbind . odd . unCXInteger - property "add" = \a-> return $ TwineFunction (\[n]-> do - i <- cxToInteger n - mbind $ (unCXInteger a + i) - ) - property "subtract" = \a-> return $ TwineFunction (\[n]-> do - i <- cxToInteger n - mbind $ (unCXInteger a - i) - ) - -mbind = return . bind - -signal sig (TwineObject obj) = (getContext obj) sig - -cxToInteger (TwineInteger i) = return i -cxToInteger cm@(TwineObject obj) = do - v <- signal "toInteger" cm - case v of - TwineInteger i -> return i - TwineNull -> error "expected number but got null value" - _ -> error ("'" ++ show v ++ "' is not a number") - - - diff --git a/src/Text/Twine/Interpreter/Interface.hs b/src/Text/Twine/Interpreter/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Text/Twine/Interpreter/Interface.hs @@ -0,0 +1,153 @@ +{-#LANGUAGE MultiParamTypeClasses + , TypeSynonymInstances + , FlexibleInstances + , FlexibleContexts + , NoMonomorphismRestriction + , OverlappingInstances + , OverloadedStrings + , UndecidableInstances + , FunctionalDependencies + #-} + +module Text.Twine.Interpreter.Interface (TemplateInterface (..), emptyContext, bind, unbind, method) where + +import Control.Monad.Writer +import Data.ByteString.Char8 (ByteString) +import Data.Convertible.Base +import Data.Maybe +import Data.Monoid +import Text.Twine.Interpreter.Types +import qualified Data.ByteString.Char8 as C +import qualified Data.Map as M + + +class (Monad m) => TemplateInterface m a | a -> m where + property :: ByteString -> a -> m (TwineElement m) + makeIterable :: a -> m [TwineElement m] + makeString :: a -> m String + + property _ _ = return TwineNull + makeIterable _ = return [] + makeString _ = return "" + + +instance (Monad m, TemplateInterface m a) => Convertible a (TwineElement m) where + safeConvert a = Right $ TwineObject $ Context { + getContext = (flip property a), + getIterable = makeIterable a, + getString = makeString a + } + +------------------------------------------------------------------------ + +bind :: (Convertible a (TwineElement m), Monad m) => a -> TwineElement m +bind = convert + +unbind :: (Convertible (TwineElement m) a, Monad m) => TwineElement m -> a +unbind = convert + +method :: (Monad m) => ([TwineElement m] -> m (TwineElement m)) -> TwineElement m +method = TwineFunction + +------------------------------------------------------------------------ + +instance (Monad m) => Convertible String (TwineElement m) where + safeConvert = Right . TwineString . C.pack + +instance (Monad m) => Convertible ByteString (TwineElement m) where + safeConvert = Right . TwineString + +instance (Monad m) => Convertible Bool (TwineElement m) where + safeConvert = Right . TwineBool + +instance (Monad m) => Convertible ([TwineElement m] -> m (TwineElement m)) (TwineElement m) where + safeConvert = Right . TwineFunction + +instance (Monad m, Convertible a (TwineElement m)) => Convertible (Maybe a) (TwineElement m) where + safeConvert (Just a) = Right $ bind a + safeConvert Nothing = Right $ TwineNull + +instance (Monad m) => TemplateInterface m (TwineElement m) where + makeString = return . show + +instance (Monad m) => TemplateInterface m EmptyContext + +instance (Monad m, Convertible a (TwineElement m)) => Convertible [a] (TwineElement m) where + safeConvert = Right . bind . CXListLike . map bind + +instance (Monad m) => Convertible Int (TwineElement m) where + safeConvert = Right . bind . CXInteger . fromIntegral + +instance (Monad m) => Convertible Integer (TwineElement m) where + safeConvert = Right . bind . CXInteger + +instance (Monad m) => Convertible (TwineElement m) (TwineElement m) where + safeConvert = Right + +instance (Monad m) => TemplateInterface m [(ByteString,TwineElement m)] where + property k = return . bind . lookup k + +instance (Monad m) => TemplateInterface m (M.Map ByteString (TwineElement m)) where + property k = return . bind . M.lookup k + +------------------------------------------------------------------------ + +instance (Monad m) => TemplateInterface m (CXListLike m) where + property "length" = return . bind . length . unCXListLike + property "head" = mbind . head . unCXListLike + property "tail" = return . bind . tail . unCXListLike + property "init" = return . bind . init . unCXListLike + property "last" = mbind . last . unCXListLike + property "item" = \x -> return $ method (\[n] -> do + i <- unbind n + mbind (unCXListLike x !! i)) + + property "take" = \x -> return $ method (\[n] -> do + i <- unbind n + mbind . take i $ unCXListLike x) + + property "drop" = \x -> return $ method (\[n] -> do + i <- unbind n + mbind . drop i $ unCXListLike x) + + makeIterable = return . unCXListLike + makeString = \_-> return "" + + +instance (Monad m) => TemplateInterface m CXInteger where + makeString = return . show . unCXInteger + property "toInteger" = return . TwineInteger . unCXInteger + property "even?" = mbind . even . unCXInteger + property "odd?" = mbind . odd . unCXInteger + property "add" = \a-> return $ method (\[n]-> do + i <- unbind n + mbind $ (unCXInteger a + i) + ) + property "subtract" = \a-> return $ method (\[n]-> do + i <- unbind n + mbind $ (unCXInteger a - i) + ) +mbind :: (Convertible a (TwineElement m), Monad m) => a -> m (TwineElement m) +mbind = return . bind + +emptyContext :: (Monad m) => TwineElement m +emptyContext = bind EmptyContext + +instance (Monad m) => Convertible (TwineElement m) (m Int) where + safeConvert = Right . cxToInteger + +instance (Monad m) => Convertible (TwineElement m) (m Integer) where + safeConvert = Right . cxToInteger + +instance (Monad m) => Convertible (TwineElement m) (m Bool) where + safeConvert = Right . cxToBool + +cxToInteger (TwineInteger i) = + return (fromIntegral i) +cxToInteger cm@(TwineObject obj) = + signal "toInteger" cm >>= convert + +signal :: ByteString -> TwineElement t -> t (TwineElement t) +signal sig (TwineObject obj) = (getContext obj) sig + +cxToBool (TwineBool b) = return b diff --git a/src/Text/Twine/Interpreter/Types.hs b/src/Text/Twine/Interpreter/Types.hs --- a/src/Text/Twine/Interpreter/Types.hs +++ b/src/Text/Twine/Interpreter/Types.hs @@ -1,22 +1,20 @@ {-#LANGUAGE MultiParamTypeClasses , TypeSynonymInstances , FlexibleInstances - , UndecidableInstances - , FlexibleContexts + , FlexibleContexts + , NoMonomorphismRestriction , OverlappingInstances , OverloadedStrings - , NoMonomorphismRestriction + , UndecidableInstances , FunctionalDependencies #-} module Text.Twine.Interpreter.Types where import qualified Data.ByteString.Char8 as C -import Data.ByteString.Char8 (ByteString,pack) -import Control.Monad.Writer -import Control.Monad.Identity -import Control.Monad.Trans +import Data.ByteString.Char8 (ByteString) import qualified Data.Map as M +import Data.Convertible.Base data TwineElement m = TwineObjectList [Context m] | TwineObject (Context m) @@ -27,20 +25,6 @@ | TwineList [TwineElement m] | TwineFunction ([TwineElement m] -> m (TwineElement m)) -newtype CXListLike m = CXListLike { unCXListLike :: [TwineElement m] } -newtype CXInteger = CXInteger { unCXInteger :: Integer } - -type BuiltinFunc m = [TwineElement m] -> m (TwineElement m) - -data ContextState m = ContextState { getContextState :: (TwineElement m) - , getContextFuns :: M.Map C.ByteString (BuiltinFunc m) } - - -instance (Monad m) => Eq (TwineElement m) where - (TwineString x) == (TwineString y) = x == y - (TwineList x) == (TwineList y) = x == y - _ == _ = error "Unable to determine equality." - instance (Monad m) => Show (TwineElement m) where show (TwineString x) = C.unpack x show (TwineObjectList _) = "((TwineObject))" @@ -49,13 +33,28 @@ show (TwineBool x) = show x show (TwineNull) = "" show (TwineFunction _) = "((TwineFunction))" + show _ = "" -data EmptyContext = EmptyContext +instance (Monad m) => Eq (TwineElement m) where + (TwineString x) == (TwineString y) = x == y + (TwineList x) == (TwineList y) = x == y + _ == _ = error "Unable to determine equality." + +newtype CXListLike m = CXListLike { unCXListLike :: [TwineElement m] } +newtype CXInteger = CXInteger { unCXInteger :: Integer } + +type BuiltinFunc m = [TwineElement m] -> m (TwineElement m) + +data ContextState m = ContextState { getContextState :: (TwineElement m) + , getContextFuns :: M.Map C.ByteString (BuiltinFunc m) } + data Context m = Context { getContext :: ByteString -> m (TwineElement m), getIterable :: m [TwineElement m], getString :: m String } + +data EmptyContext = EmptyContext diff --git a/src/Text/Twine/Parser.hs b/src/Text/Twine/Parser.hs --- a/src/Text/Twine/Parser.hs +++ b/src/Text/Twine/Parser.hs @@ -86,6 +86,8 @@ -- Expressions ------------------------------------------------------------------------ +-- TODO Remove the cruft from the original expression parser. + accessor = do a <- try method <|> try atom "property or method" char '.' @@ -165,9 +167,3 @@ loadTemplateFromString :: String -> Template loadTemplateFromString = parseTemplate "theTemplate" - - - - - - diff --git a/src/Text/Twine/Parser/Types.hs b/src/Text/Twine/Parser/Types.hs --- a/src/Text/Twine/Parser/Types.hs +++ b/src/Text/Twine/Parser/Types.hs @@ -1,30 +1,26 @@ module Text.Twine.Parser.Types where -import qualified Data.ByteString.Char8 as C - -type Key = C.ByteString -type Name = C.ByteString +import Data.ByteString.Char8 (ByteString) +type Key = ByteString +type Name = ByteString type Template = [TemplateCode] -data Expr = Func Name [Expr] - | Var Name - | StringLiteral C.ByteString - | NumberLiteral Integer - | Accessor Expr Expr - deriving (Show,Read,Eq) +data Expr = + Func Name [Expr] + | Var Name + | StringLiteral ByteString + | NumberLiteral Integer + | Accessor Expr Expr + deriving (Show,Read,Eq) -data TemplateCode = Text C.ByteString - | Slot Expr - | Loop Expr Key [TemplateCode] - | Cond Expr [TemplateCode] - | Incl FilePath - | Assign Key Expr - deriving (Show) +data TemplateCode = + Text ByteString + | Slot Expr + | Loop Expr Key [TemplateCode] + | Cond Expr [TemplateCode] + | Incl FilePath + | Assign Key Expr + deriving (Show) -data ParserState = ParserState { getBlocks :: [TemplateCode] - , getTextQ :: C.ByteString - , getTemplate :: C.ByteString } deriving (Show) - -makePS = ParserState [] C.empty diff --git a/twine.cabal b/twine.cabal --- a/twine.cabal +++ b/twine.cabal @@ -1,5 +1,5 @@ name: twine -version: 0.1.1 +version: 0.1.2 synopsis: very simple template language description: very simple template language category: Text @@ -20,16 +20,16 @@ , filepath >= 1.1.0.3 , parsec >= 3 , containers >= 0.3 + , convertible Exposed-modules: Text.Twine Other-modules: Text.Twine.Parser ,Text.Twine.Parser.Types ,Text.Twine.Interpreter - ,Text.Twine.Interpreter.Context + ,Text.Twine.Interpreter.Interface ,Text.Twine.Interpreter.ContextWriter - ,Text.Twine.Interpreter.FancyContext ,Text.Twine.Interpreter.Types ,Text.Twine.Interpreter.Builtins - ghc-options: -O2 -fvia-C + ghc-options: -O2 -fvia-C