{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Text.Heterocephalus.Parse.Doc where
#if MIN_VERSION_base(4,9,0)
#else
import Control.Applicative ((*>), (<*), pure)
#endif
import Control.Monad (void)
import Data.Data (Data)
import Data.Typeable (Typeable)
import Text.Parsec
(Parsec, ParseError, SourcePos, (<|>), eof, incSourceLine, many,
many1, optional, optionMaybe, parse, tokenPrim)
import Text.Shakespeare.Base (Deref)
import Text.Hamlet.Parse
import Text.Heterocephalus.Parse.Control (Content(..), Control(..))
data Doc = DocForall Deref Binding [Doc]
| DocCond [(Deref, [Doc])] (Maybe [Doc])
| DocCase Deref [(Binding, [Doc])]
| DocContent Content
deriving (Data, Eq, Read, Show, Typeable)
type DocParser = Parsec [Control] ()
parseDocFromControls :: [Control] -> Either ParseError [Doc]
parseDocFromControls = parse (docsParser <* eof) ""
docsParser :: DocParser [Doc]
docsParser = many docParser
docParser :: DocParser Doc
docParser = forallDoc <|> condDoc <|> caseDoc <|> contentDoc
forallDoc :: DocParser Doc
forallDoc = do
ControlForall deref binding <- forallControlStatement
innerDocs <- docsParser
void endforallControlStatement
pure $ DocForall deref binding innerDocs
condDoc :: DocParser Doc
condDoc = do
ControlIf ifDeref <- ifControlStatement
ifInnerDocs <- docsParser
elseIfs <- condElseIfs
maybeElseInnerDocs <- optionMaybe $ elseControlStatement *> docsParser
void endifControlStatement
let allConds = (ifDeref, ifInnerDocs) : elseIfs
pure $ DocCond allConds maybeElseInnerDocs
caseDoc :: DocParser Doc
caseDoc = do
ControlCase caseDeref <- caseControlStatement
optional contentDoc
caseOfs <- many1 $ do
ControlCaseOf caseBinding <- caseOfControlStatement
innerDocs <- docsParser
pure (caseBinding, innerDocs)
void endcaseControlStatement
pure $ DocCase caseDeref caseOfs
contentDoc :: DocParser Doc
contentDoc = primControlStatement $ \case
NoControl content -> Just $ DocContent content
_ -> Nothing
condElseIfs :: DocParser [(Deref, [Doc])]
condElseIfs = many $ do
ControlElseIf elseIfDeref <- elseIfControlStatement
elseIfInnerDocs <- docsParser
pure (elseIfDeref, elseIfInnerDocs)
ifControlStatement :: DocParser Control
ifControlStatement = primControlStatement $ \case
ControlIf deref -> Just $ ControlIf deref
_ -> Nothing
elseIfControlStatement :: DocParser Control
elseIfControlStatement = primControlStatement $ \case
ControlElseIf deref -> Just $ ControlElseIf deref
_ -> Nothing
elseControlStatement :: DocParser Control
elseControlStatement = primControlStatement $ \case
ControlElse -> Just ControlElse
_ -> Nothing
endifControlStatement :: DocParser Control
endifControlStatement = primControlStatement $ \case
ControlEndIf -> Just ControlEndIf
_ -> Nothing
caseControlStatement :: DocParser Control
caseControlStatement = primControlStatement $ \case
ControlCase deref -> Just $ ControlCase deref
_ -> Nothing
caseOfControlStatement :: DocParser Control
caseOfControlStatement = primControlStatement $ \case
ControlCaseOf binding -> Just $ ControlCaseOf binding
_ -> Nothing
endcaseControlStatement :: DocParser Control
endcaseControlStatement = primControlStatement $ \case
ControlEndCase -> Just ControlEndCase
_ -> Nothing
forallControlStatement :: DocParser Control
forallControlStatement = primControlStatement $ \case
ControlForall deref binding -> Just $ ControlForall deref binding
_ -> Nothing
endforallControlStatement :: DocParser Control
endforallControlStatement = primControlStatement $ \case
ControlEndForall -> Just ControlEndForall
_ -> Nothing
primControlStatement :: (Control -> Maybe x)-> DocParser x
primControlStatement = tokenPrim show incSourcePos
incSourcePos :: SourcePos -> a -> b -> SourcePos
incSourcePos sourcePos _ _ = incSourceLine sourcePos 1