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.Core.Transform.Snip as Snip
import qualified DDC.Core.Transform.Beta as Beta
import qualified DDC.Core.Transform.Eta as Eta
import qualified DDC.Core.Transform.FoldCase as FoldCase
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
"Beta" -> Just (Beta Beta.configZero)
"BetaLets" -> Just (Beta Beta.configZero { Beta.configBindRedexes = True })
"Bubble" -> Just Bubble
"Elaborate" -> Just Elaborate
"Eta" -> Just (Eta Eta.configZero { Eta.configExpand = True })
"Flatten" -> Just Flatten
"Forward" -> Just Forward
"FoldCase" -> Just (FoldCase FoldCase.configZero
{ FoldCase.configCaseOfConstructor = True
, FoldCase.configCaseOfCase = True })
"Lambdas" -> Just Lambdas
"Prune" -> Just Prune
"Snip" -> Just (Snip Snip.configZero)
"SnipOver" -> Just (Snip Snip.configZero { Snip.configSnipOverApplied = True })
"SnipBody" -> Just (Snip Snip.configZero { Snip.configSnipLetBody = True })
_ -> 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