module DDC.Core.Simplifier.Parser
( SimplifierDetails (..)
, parseSimplifier)
where
import DDC.Core.Transform.Namify
import DDC.Core.Transform.Inline
import DDC.Core.Simplifier.Base
import DDC.Core.Module
import DDC.Type.Env
import DDC.Core.Simplifier.Lexer
import DDC.Data.Token
import DDC.Data.SourcePos
import DDC.Base.Parser (pTok)
import Data.Set (Set)
import qualified DDC.Base.Parser as P
import qualified Data.Map as Map
import qualified Data.Set as Set
data SimplifierDetails s a n
= SimplifierDetails
{
simplifierMkNamifierT :: Env n -> Namifier s n
, simplifierMkNamifierX :: Env n -> Namifier s n
, simplifierRules :: NamedRewriteRules a n
, simplifierTemplates :: [Module a n] }
type Parser n a
= P.Parser (Tok n) a
parseSimplifier
:: (Ord n, Show n)
=> (String -> Maybe n)
-> SimplifierDetails s a n
-> String
-> Either P.ParseError (Simplifier s a n)
parseSimplifier readName details str
= let kend = Token KEnd (SourcePos "<simplifier spec>" 0 0)
toks = lexSimplifier readName str ++ [kend]
in P.runTokenParser show "<simplifier spec>"
(pSimplifier details)
toks
pSimplifier
:: (Ord n, Show n)
=> SimplifierDetails s a n
-> Parser n (Simplifier s a n)
pSimplifier details
= do simpl <- pSimplifierSeq details
pTok KEnd
return simpl
pSimplifierSeq
:: (Ord n, Show n)
=> SimplifierDetails s a n
-> Parser n (Simplifier s a n)
pSimplifierSeq details
= P.choice
[ do
simpl0 <- pSimplifier0 details
P.choice
[ do pTok KSemiColon
simpl1 <- pSimplifierSeq details
return $ Seq simpl0 simpl1
, do return simpl0 ]
]
pSimplifier0
:: (Ord n, Show n)
=> SimplifierDetails s a n
-> Parser n (Simplifier s a n)
pSimplifier0 details
= P.choice
[
do pTok KFix
maxIters <- pInt
simp <- pSimplifier0 details
return $ Fix maxIters simp
, do
trans <- pTransform details
return $ Trans trans
, do
pTok KBraceBra
simpl <- pSimplifierSeq details
pTok KBraceKet
return simpl
]
pTransform
:: (Ord n, Show n)
=> SimplifierDetails s a n
-> Parser n (Transform s a n)
pTransform details
= P.choice
[
do trans <- P.pTokMaybe readTransformAtomic
return trans
, do pTok (KCon "Namify")
return $ Namify (simplifierMkNamifierT details)
(simplifierMkNamifierX details)
, do pTok (KCon "Rewrite")
return $ Rewrite (simplifierRules details)
, do pTok (KCon "Inline")
let modules = simplifierTemplates details
specs <- P.many pInlinerSpec
let specsMap = Map.fromList specs
return $ Inline (lookupTemplateFromModules specsMap modules) ]
pInlinerSpec
:: (Ord n, Show n)
=> Parser n (ModuleName, InlineSpec n)
pInlinerSpec
= P.choice
[ do modname <- pModuleName
P.choice
[ pInlinerSpecIncludeList modname
, pInlinerSpecExcludeList modname
, return (modname, InlineSpecAll modname (Set.empty :: Set n)) ]
]
pInlinerSpecIncludeList modname
= do P.choice [ pTok KPlus, return () ]
pTok KSquareBra
ns <- P.sepEndBy pVar (pTok KComma)
pTok KSquareKet
return $ (modname, InlineSpecNone modname (Set.fromList ns))
pInlinerSpecExcludeList modname
= do pTok KMinus
pTok KSquareBra
ns <- P.sepEndBy pVar (pTok KComma)
pTok KSquareKet
return $ (modname, InlineSpecAll modname (Set.fromList ns))
readTransformAtomic :: Tok n -> Maybe (Transform s a n)
readTransformAtomic kk
| KCon name <- kk
= case name of
"Id" -> Just Id
"Anonymize" -> Just Anonymize
"Snip" -> Just Snip
"SnipOver" -> Just SnipOver
"Flatten" -> Just Flatten
"Beta" -> Just Beta
"BetaLets" -> Just BetaLets
"Prune" -> Just Prune
"Forward" -> Just Forward
"Bubble" -> Just Bubble
"Elaborate" -> Just Elaborate
_ -> Nothing
| otherwise
= Nothing
pVar :: Parser n n
pVar = P.pTokMaybe f
where f (KVar n) = Just n
f _ = Nothing
pInt :: Parser n Int
pInt = P.pTokMaybe f
where f (KInt i) = Just i
f _ = Nothing
pModuleName :: Parser n ModuleName
pModuleName = P.pTokMaybe f
where f (KCon n) = Just $ ModuleName [n]
f _ = Nothing