module Plat.Template
(
CharNumber,
LineNumber,
Pos,
Template(..),
TemplateErrLeft(..),
TemplateErrRight(..),
TemplateErr(..),
TemplateElement(..),
posContext,
template,
templateErr,
templateE
) where
import Control.Arrow
import Control.Monad.Error
import Control.Monad.State
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.UTF8 as LU
import Data.Char
import Plat.Template.Command
import Plat.Template.Errors
import Plat.Utils
newtype Template = Template [TemplateElement]
data TemplateElement =
StringTemplate L.ByteString |
ExprTemplate Pos [B.ByteString] |
LoopTemplate (Pos, Pos) [B.ByteString] B.ByteString Template |
OptionTemplate (Pos, Pos) [Template] |
CheckTemplate Pos [B.ByteString]
data Partial = Partial [([TemplateElement], Pos, ReadingState)] [TemplateElement]
data ReadingState = ReadingLoop [B.ByteString] B.ByteString | ReadingOption [Template]
addCommand :: (Partial, LineNumber) -> Command -> (Either TemplateErr) (Partial, LineNumber)
addCommand (Partial rs elts, ln) (SimpleCmd (StringCmd str)) =
return (Partial rs $ elts ++ [StringTemplate str], ln)
addCommand pn (SimpleCmd NopCmd) = return pn
addCommand (Partial rs elts, ln) (SimpleCmd AtCmd) =
return (Partial rs $ elts ++ [StringTemplate $ LU.fromString "@"], ln)
addCommand (Partial rs elts, ln) (ControlCmd pos TryCmd) =
return (Partial ((elts, (ln, pos), ReadingOption []) : rs) [], ln)
addCommand (Partial rs elts, ln) (ControlCmd pos EndTryCmd) =
case rs of
[] -> Left $ NoLeftTag TryRightTag (ln, pos)
(_, p, ReadingLoop _ _) : _ ->
Left $ MismatchedTags LoopLeftTag p TryRightTag (ln, pos)
(elts', p, ReadingOption tmps) : rs' ->
let newElt = OptionTemplate (p, (ln, pos)) $ tmps ++ [Template elts]
in return (Partial rs' $ elts' ++ [newElt], ln)
addCommand (Partial rs elts, ln) (ControlCmd pos OrCmd) =
case rs of
[] -> Left $ NoLeftTag OrRightTag (ln, pos)
(_, p, ReadingLoop _ _) : _ ->
Left $ MismatchedTags LoopLeftTag p OrRightTag (ln, pos)
(elts', p, ReadingOption tmps) : rs' ->
let newSt = ReadingOption $ tmps ++ [Template elts]
in return (Partial ((elts', p, newSt) : rs') [], ln)
addCommand (Partial rs elts, ln) (ControlCmd pos (GuardCmd expr)) =
return (Partial rs $ elts ++ [CheckTemplate (ln, pos) expr], ln)
addCommand (Partial rs elts, ln) (ControlCmd pos (LoopCmd expr var)) =
return (Partial ((elts, (ln, pos), ReadingLoop expr var) : rs) [], ln)
addCommand (Partial rs elts, ln) (ControlCmd pos EndLoopCmd) =
case rs of
[] -> Left $ NoLeftTag LoopRightTag (ln, pos)
(elts', p, ReadingLoop expr var) : rs' ->
let newElt = LoopTemplate (p, (ln, pos)) expr var $ Template elts
in return (Partial rs' $ elts' ++ [newElt], ln)
(_, p, ReadingOption _) : _ ->
Left $ MismatchedTags TryLeftTag p LoopRightTag (ln, pos)
addCommand (Partial rs elts, ln) (SubstCmd pos expr) =
return (Partial rs $ elts ++ [ExprTemplate (ln, pos) expr], ln)
addCommand (p, _) (LineCmd line) = return (p, line)
templateE :: L.ByteString -> Either TemplateErr Template
templateE s =
do (Partial rs elts, _) <- foldM addCommand (Partial [] [], 0) $ commands s
case rs of
[] -> return $ Template elts
(_, p, ReadingLoop _ _) : _ -> Left $ NoRightTag LoopLeftTag p
(_, p, ReadingOption _) : _ -> Left $ NoRightTag TryLeftTag p
template :: L.ByteString -> Template
template s =
case templateE s of
Left err -> error $ show err
Right t -> t