MODULE {Transform} {} {} PRAGMA genlinepragmas INCLUDE "BackendAg.ag" imports { import BackendAst import CommonTypes import UU.Scanner.Position import Data.Map(Map) import qualified Data.Map as Map import Data.Set(Set) import qualified Data.Set as Set import Language.Haskell.Pretty import Language.Haskell.Syntax import System.FilePath import qualified Data.ByteString.Char8 as B import Data.Maybe import Debug.Trace } WRAPPER Ag { transform :: Ag -> String transform ast = B.unpack (output_Syn_Ag syn) where sem = sem_Ag ast syn = wrap_Ag sem inh inh = Inh_Ag {} nextUnique :: Int -> (Int, Int) nextUnique n = (n+1, n) find :: (Show k, Ord k, Show a, Show p) => p -> k -> Map k a -> a find p k m = Map.findWithDefault (error (show p ++ ": no key " ++ show k ++ " in " ++ show m)) k m } ---------------- -- Analysis part ---------------- -- -- Determine pat or expr context for all code parts -- ATTR Code Tks Tk [ isExprCtx : Bool | | ] SEM Block | Code code.isExprCtx = True -- never evaluated SEM Stmt | ChildSem code.isExprCtx = True | VisitSem code.isExprCtx = True | Match pat.isExprCtx = False expr.isExprCtx = True | Eval pat.isExprCtx = False expr.isExprCtx = True SEM Clause | External code.isExprCtx = True SEM Param | Param type.isExprCtx = True -- -- Pass the identifier context downwards -- ATTR ItfVisits ItfVisit [ | ctxIdents : {[Ident]} | ] SEM Interface | Interface visits.ctxIdents = [] SEM ItfVisit | Visit loc.ctxIdents = @lhs.ctxIdents ++ @ctx -- -- Gather and spread interface information -- ATTR Blocks Block Interface [ | | gathItfMap USE {`Map.union`} {Map.empty} : ItfMap ] ATTR Blocks Block Code Tks Tk Sem Prods Prod ProdVisits ProdVisit Clauses Clause Stmts Stmt [ itfMap : ItfMap | | ] ATTR ItfVisits ItfVisit [ | | visitInfos USE {++} {[]} : {[ItfVisitInfo]} ] ATTR ItfVisit [ allCurrentInfos : {[ItfVisitInfo]} | | ] SEM Ag | Ag blocks.itfMap = @blocks.gathItfMap SEM Interface | Interface lhs.gathItfMap = Map.singleton @name @visits.visitInfos SEM ItfVisits | Cons hd.allCurrentInfos = @hd.visitInfos ++ @tl.visitInfos SEM ItfVisit | Visit lhs.visitInfos = [ @loc.visitInfo ] loc.visitInfo = ItfVisitInfo @loc.ctxIdents @name @lhs.nextVisitName @params.params SEM Param | Param type.itfMap = Map.empty { -- Per "interface" a list of visits with inputs and outputs type ItfMap = Map Ident [ItfVisitInfo] data ItfVisitInfo = ItfVisitInfo { itfCtx :: ![Ident] , itfVisit :: !Ident , itfNextVisit :: !(Maybe Ident) , itfParams :: ![TypedParam] } deriving (Eq, Ord, Show) itfInputs, itfOutputs :: ItfVisitInfo -> [Ident] itfInputs = map paramName . filter paramIsInput . itfParams itfOutputs = map paramName . filter (not.paramIsInput) . itfParams } -- -- List of typed paramters (at ItfVisit and Interface level) -- ATTR ItfVisits ItfVisit Params Param [ | | params USE {++} {[]} : TypedParams ] SEM Param | Param lhs.params = [TypedParam @name @type.output @isInput] ATTR ItfVisit [ allCurrentParams : TypedParams | | ] SEM ItfVisits | Cons hd.allCurrentParams = @hd.params ++ @tl.params { type TypedParams = [TypedParam] data TypedParam = TypedParam { paramName :: !Ident , paramType :: !B.ByteString , paramIsInput :: !Bool } deriving (Eq, Ord, Show) } -- -- collect the defined fields of each clause -- ATTR Clause Stmts Stmt [ | | defs USE {`Set.union`} {Set.empty} : {Set AttrOcc} ] SEM Clause | External lhs.defs = Set.fromList $ map (\p -> AttrOcc lhsIdent p AtOutput) (itfOutputs @lhs.visitInfo) SEM Stmt | ChildSem lhs.defs = Set.empty | VisitSem lhs.defs = Set.fromList @loc.defsL loc.defsL = @loc.semDefs ++ @loc.outpDefs loc.semDefs = case @loc.mbNextVisit of Just v -> [ AttrOcc @name v AtSem ] Nothing -> [] loc.outpDefs = [ AttrOcc @name outp AtInput | outp <- itfOutputs @loc.visitInfo ] | Match Eval lhs.defs = @pat.attrs ATTR Code Tks Tk [ | | attrs USE {`Set.union`} {Set.empty} : {Set AttrOcc} ] SEM Tk | Ident lhs.attrs = Set.singleton $ AttrOcc @child @name $ toInOutClass @lhs.isExprCtx { data AttrOcc = AttrOcc !Ident !Ident !AttrClass -- child + field + type deriving (Show, Eq, Ord) data AttrClass = AtSem | AtInput | AtOutput | AtLocal deriving (Show, Eq, Ord) toInOutClass :: Bool -> AttrClass toInOutClass True = AtInput toInOutClass False = AtOutput } ATTR Clauses [ | | defs : {[Set AttrOcc]} ] SEM Clauses | Cons lhs.defs = @hd.defs : @tl.defs | Nil lhs.defs = [] SEM ProdVisit | Visit loc.commonDefs = foldr1 Set.intersection @clauses.defs loc.commonVars = map (\(AttrOcc chld nm atClass) -> toFieldHsn atClass chld nm) (Set.toList @loc.commonDefs) ATTR Clauses Clause [ commonVars : {[HsName]} | | ] -- -- Synthesize and spread defined children through a production -- -- invariant: contains the children in scope, with their interface name ATTR ProdVisits ProdVisit [ | childInfo : {Map Ident Ident} | ] ATTR Clauses Clause Stmts Stmt [ childInfo : {Map Ident Ident} | | ] SEM Prod | Prod visits.childInfo = Map.empty SEM ProdVisit | Visit loc.newChildInfos = foldr1 Map.intersection @clauses.gathChildInfos loc.childInfo = @loc.newChildInfos `Map.union` @lhs.childInfo ATTR Clause Stmts Stmt [ | | gathChildInfo USE {`Map.union`} {Map.empty} : {Map Ident Ident} ] ATTR Clauses [ | | gathChildInfos : {[Map Ident Ident]} ] SEM Clauses | Cons lhs.gathChildInfos = @hd.gathChildInfo : @tl.gathChildInfos | Nil lhs.gathChildInfos = [] SEM Stmt | ChildSem lhs.gathChildInfo = Map.singleton @name @type -- -- Obtain relevant interface info -- SEM Stmt | ChildSem VisitSem loc.type = find @pos @name @lhs.childInfo | ChildSem loc.visitsInfo = findItf @pos @loc.type @mbVisit @lhs.itfMap loc.firstVisitInfo = head @loc.visitsInfo | VisitSem loc.visitsInfo = find @pos @loc.type @lhs.itfMap loc.visitInfo = findVisitInfo @pos @visit @loc.visitsInfo loc.mbNextVisit = itfNextVisit @loc.visitInfo SEM Sem | Sem loc.visitsInfo = findItf @pos @type @mbVisit @lhs.itfMap loc.firstVisit = head @loc.visitsInfo ATTR Prods Prod ProdVisits ProdVisit [ semType : {Ident} | | ] SEM Sem | Sem prods.semType = @type ATTR Prods Prod ProdVisits ProdVisit [ visitsInfo : {[ItfVisitInfo]} | | ] ATTR Clauses Clause [ visitInfo : ItfVisitInfo | | ] SEM ProdVisit | Visit loc.visitInfo = findVisitInfo @pos @name @lhs.visitsInfo { findItf :: Pos -> Ident -> Maybe Ident -> Map Ident [ItfVisitInfo] -> [ItfVisitInfo] findItf p i mb mp = from mb $ find p i mp where from Nothing = id from (Just nm) = from' where from' [] = error (show p ++ ": empty visits " ++ show i ++ ":" ++ show nm) from' z@(x:xs) | itfVisit x == nm = z | otherwise = from' xs findVisitInfo :: Pos -> Ident -> [ItfVisitInfo] -> ItfVisitInfo findVisitInfo p n (v:vs) | itfVisit v == n = v | otherwise = findVisitInfo p n vs findVisitInfo p n [] = error (show p ++ ": no visit " ++ show n) } ATTR Prods Prod Prod ProdVisits ProdVisit [ | | fstVisitStatic USE {||} {False} : Bool ] SEM ProdVisit | Visit lhs.fstVisitStatic = @isStatic SEM ProdVisits | Cons lhs.fstVisitStatic = @hd.fstVisitStatic -- -- Hand out match variables -- ATTR Clauses Clause Stmts Stmt [ | uniq : Int | ] ATTR Stmts Stmt [ | | matchVars USE {++} {[]} : {[HsName]} ] SEM ProdVisit | Visit clauses.uniq = 1 SEM Stmt | Match loc.matchNr : UNIQUEREF uniq loc.matchVar = matchNameId @loc.matchNr lhs.matchVars = [ @loc.matchVar ] { matchNameId :: Int -> HsName matchNameId n = HsIdent ("__match_" ++ show n) } -- -- Check if this visit is the last visit -- ATTR ProdVisits [ | | hasNextVisits : Bool ] ATTR ProdVisit Clauses Clause [ isLastVisit : Bool | | ] SEM ProdVisits | Cons hd.isLastVisit = not @tl.hasNextVisits lhs.hasNextVisits = True | Nil lhs.hasNextVisits = False -- -- Check if this visit is the first visit -- ATTR ProdVisits ProdVisit Clauses Clause [ isFirstVisit : Bool | | ] SEM Prod | Prod visits.isFirstVisit = True SEM ProdVisits | Cons tl.isFirstVisit = False -- -- Check if internal clauses are defined -- ATTR Clauses Clause [ | | hasInternalClauses USE {||} {False} : Bool ] SEM Clause | Internal lhs.hasInternalClauses = True -- -- Thread next visit name from right to left through the interface definition -- ATTR ItfVisits ItfVisit [ | | nextVisitName : {Maybe Ident} ] ATTR ItfVisit [ nextVisitName : {Maybe Ident} | | ] SEM ItfVisits | Cons hd.nextVisitName = @tl.nextVisitName lhs.nextVisitName = @hd.nextVisitName | Nil lhs.nextVisitName = Nothing SEM ItfVisit | Visit lhs.nextVisitName = Just @name -- -- *** Code generation part *** -- -- -- Code blocks -- -- compute strings from (code) blocks ATTR Ag Blocks Block Code Tks Tk Interface [ | | output USE {`B.append`} {B.empty} : {B.ByteString} ] SEM Interface | Interface lhs.output = B.unlines ( ppHaskell @loc.decl : map ppHaskell @visits.decls ) -- invariant: start with as many spaces as the the code -- block starts in the source file SEM Code | Code lhs.output = @loc.spacing `B.append` @tokens.output loc.spacing = B.replicate (column @pos) ' ' SEM Tk | String lhs.output = B.pack @str | Ident lhs.output = B.pack $ toFieldName (toInOutClass @lhs.isExprCtx) @child @name | Visit lhs.output = B.pack $ show $ semName @child @name | Sem lhs.output = B.unlines ( [ B.pack "(let {" , ppHaskell @sem.decl , B.pack ("} in " ++ lhsIdentStr ++ ")") , B.replicate (column @posEnd) ' ' ] ) { ppHaskell :: Pretty a => a -> B.ByteString ppHaskell h = B.pack $ prettyPrintWithMode modePP h modePP :: PPHsMode modePP = defaultMode { layout = PPSemiColon, linePragmas = False } posToSrcLoc :: Pos -> SrcLoc posToSrcLoc (Pos l c f) = SrcLoc f l c identToHsn :: Ident -> HsName identToHsn = HsIdent . show lhsIdent :: Ident lhsIdent = Ident "lhs" noPos lhsIdentStr :: String lhsIdentStr = "__lhs" toFieldName :: AttrClass -> Ident -> Ident -> String toFieldName isInput child name | cStr == "loc" = out AtLocal | otherwise = out isInput where cStr = show child nStr = show name out c = "_" ++ cStr ++ byClass c ++ nStr byClass AtLocal = "L" byClass AtInput = "I" byClass AtOutput = "O" byClass AtSem = "S" toFieldHsn :: AttrClass -> Ident -> Ident -> HsName toFieldHsn attrClass child name = HsIdent $ toFieldName attrClass child name } -- -- Type definitions and signatures from interface definitions -- SEM Interface | Interface loc.srcLoc = posToSrcLoc @pos visits.tycon = @name loc.decl = HsTypeDecl @loc.srcLoc (identToHsn @name) @loc.ctxVars ( appTyVars @loc.ctxVars (HsTyCon $ UnQual $ visitItfTyCon @name (itfVisit @loc.fstVisitInfo)) ) loc.fstVisitInfo = head @visits.visitInfos loc.ctxVars = map identToHsn $ itfCtx @loc.fstVisitInfo { visitItfTyCon :: Ident -> Ident -> HsName visitItfTyCon n v = HsIdent (show n ++ "_" ++ show v) visitImpTyCon :: Ident -> Ident -> HsName visitImpTyCon n v = HsIdent (show n ++ "_" ++ show v ++ "_imp") appTyVars :: [HsName] -> HsType -> HsType appTyVars xs t = foldl HsTyApp t (map HsTyVar xs) } ATTR ItfVisits ItfVisit [ tycon : {Ident} | | decls USE {++} {[]} : {[HsDecl]} ] SEM ItfVisit | Visit loc.srcLoc = posToSrcLoc @pos loc.impCon = visitImpTyCon @lhs.tycon @name loc.itfCon = visitItfTyCon @lhs.tycon @name loc.inhCon = inhTyCon @lhs.tycon @name loc.synCon = synTyCon @lhs.tycon @name loc.inhCon' = inhTyCon' @lhs.tycon @name loc.synCon' = synTyCon' @lhs.tycon @name loc.ctxVars = map identToHsn @loc.ctxIdents lhs.decls = [ -- itf type HsTypeDecl @loc.srcLoc @loc.impCon @loc.ctxVars @loc.type -- imp type , HsNewTypeDecl @loc.srcLoc [] @loc.itfCon @loc.ctxVars (HsConDecl @loc.srcLoc @loc.itfCon [HsUnBangedTy $ appTyVars @loc.ctxVars $ HsTyCon $ UnQual $ @loc.impCon]) [] -- prime types , HsDataDecl @loc.srcLoc [] @loc.inhCon' @loc.ctxVars [ HsRecDecl @loc.srcLoc @loc.inhCon' ( [ ([toInhName' @lhs.tycon @name $ paramName p] , HsUnBangedTy $ embedAsType $ paramType p) | p <- @params.params, paramIsInput p ] ) ] [] , HsDataDecl @loc.srcLoc [] @loc.synCon' [] [ HsRecDecl @loc.srcLoc @loc.synCon' ( maybe [] (\v ->[([ toSynName' @lhs.tycon @name v ] , HsUnBangedTy $ HsTyCon $ UnQual $ visitItfTyCon @lhs.tycon v ) ]) @lhs.nextVisitName ++ [ ([toSynName' @lhs.tycon @name $ paramName p] , HsUnBangedTy $ embedAsType $ paramType p) | p <- @params.params, not (paramIsInput p) ] ) ] [] -- unprimed types , HsDataDecl @loc.srcLoc [] @loc.inhCon [] [ HsRecDecl @loc.srcLoc @loc.inhCon [ ([toInhName @lhs.tycon @name $ paramName p] , HsUnBangedTy $ embedAsType $ paramType p) | p <- @lhs.allCurrentParams, paramIsInput p ] ] [] , HsDataDecl @loc.srcLoc [] @loc.synCon [] [ HsRecDecl @loc.srcLoc @loc.synCon [ ([toSynName @lhs.tycon @name $ paramName p] , HsUnBangedTy $ embedAsType $ paramType p) | p <- @lhs.allCurrentParams, not (paramIsInput p) ] ] [] -- primed wrapper , let ins = [ toFieldHsn AtInput lhsIdent (paramName p) | p <- @params.params, paramIsInput p ] outs = maybe [] (\v -> [toFieldHsn AtSem lhsIdent v]) @lhs.nextVisitName ++ [ toFieldHsn AtOutput lhsIdent (paramName p) | p <- @params.params, not (paramIsInput p)] wrapVar = HsVar $ UnQual @loc.synCon' semVar = HsVar $ UnQual semParam in HsFunBind [ HsMatch @loc.srcLoc (wrapperName' @lhs.tycon @name) [ HsPApp (UnQual @loc.itfCon) [HsPVar semParam] , HsPApp (UnQual $ @loc.inhCon') (map HsPVar ins) ] (HsUnGuardedRhs $ HsCase (foldl1 HsApp (semVar : map (HsVar . UnQual) ins)) [ HsAlt @loc.srcLoc (HsPParen $ HsPApp justQName [HsPTuple (map HsPVar outs)]) (HsUnGuardedAlt $ foldl1 HsApp ( wrapVar : map (HsVar . UnQual) outs ) ) [] , HsAlt @loc.srcLoc (HsPApp nothingQName []) (HsUnGuardedAlt $ errorExp ("no clause for: " ++ show @lhs.tycon ++ " at: " ++ show @pos)) [] ] ) [] ] -- unprimed wrapper , let ins = [ toFieldHsn AtInput lhsIdent (paramName p) | p <- @lhs.allCurrentParams, paramIsInput p ] outs = [ toFieldHsn AtOutput lhsIdent (paramName p) | p <- @lhs.allCurrentParams, not (paramIsInput p) ] wrapVar = HsVar $ UnQual @loc.synCon semVar = HsVar $ UnQual semParam createCases :: ItfVisitInfo -> HsExp -> HsExp createCases info exp = HsCase (foldl1 HsApp (semVar : map (HsVar . UnQual) ins)) [ HsAlt @loc.srcLoc (HsPParen $ HsPApp justQName [HsPTuple (semPat ++ map HsPVar outs)]) (HsUnGuardedAlt exp) [] , HsAlt @loc.srcLoc (HsPApp nothingQName []) (HsUnGuardedAlt $ errorExp ("no clause for: " ++ show @lhs.tycon ++ " at: " ++ show @pos)) [] ] where semPat = maybe [] (\v -> [HsPApp (UnQual $ visitItfTyCon @lhs.tycon v) [HsPVar semParam]] ) $ itfNextVisit info ins = [ toFieldHsn AtInput lhsIdent (paramName p) | p <- itfParams info, paramIsInput p ] outs = [ toFieldHsn AtOutput lhsIdent (paramName p) | p <- itfParams info, not (paramIsInput p) ] in HsFunBind [ HsMatch @loc.srcLoc (wrapperName @lhs.tycon @name) [ HsPApp (UnQual @loc.itfCon) [HsPVar semParam] , HsPApp (UnQual @loc.inhCon) (map HsPVar ins) ] (HsUnGuardedRhs $ foldr createCases ( foldl1 HsApp (wrapVar : map (HsVar . UnQual) outs) ) @lhs.allCurrentInfos) [] ] -- unwrapper , let funName = HsIdent "fun" ins = [ toFieldHsn AtInput lhsIdent (paramName p) | p <- @params.params, paramIsInput p ] outs = maybe [] (\v -> [toFieldHsn AtSem lhsIdent v]) @lhs.nextVisitName ++ [ toFieldHsn AtOutput lhsIdent (paramName p) | p <- @params.params, not (paramIsInput p)] in HsFunBind [ HsMatch @loc.srcLoc (unwrapperName @lhs.tycon @name) [ HsPVar semParam ] ( HsUnGuardedRhs $ HsApp (HsCon $ UnQual @loc.itfCon) (HsVar $ UnQual funName) ) [ HsFunBind [ HsMatch @loc.srcLoc funName (map HsPVar ins) ( HsUnGuardedRhs $ HsCase (HsParen $ HsApp (HsVar $ UnQual semParam) $ HsParen $ foldl1 HsApp ([ HsVar $ UnQual @loc.inhCon' ] ++ (map (HsVar . UnQual) ins))) [ HsAlt @loc.srcLoc (HsPParen $ HsPApp justQName [HsPParen $ HsPApp (UnQual @loc.synCon') (map HsPVar outs) ]) (HsUnGuardedAlt $ HsApp (HsCon $ justQName) $ HsTuple (map (HsVar . UnQual) outs) ) [] , HsAlt @loc.srcLoc (HsPApp nothingQName []) (HsUnGuardedAlt $ HsCon nothingQName) [] ] ) [] ] ] ] ] loc.maybeTp = HsTyCon $ Qual (Module "Prelude") $ HsIdent "Maybe" loc.inpTypes = [ paramType p | p <- @params.params, paramIsInput p ] loc.outTypes = [ paramType p | p <- @params.params, not (paramIsInput p) ] loc.type = foldr HsTyFun (HsTyApp @loc.maybeTp @loc.resTy) (map embedAsType @loc.inpTypes) loc.resTy = HsTyTuple ( ( case @lhs.nextVisitName of Just nm -> [HsTyCon $ UnQual $ visitItfTyCon @lhs.tycon nm] Nothing -> [] ) ++ map embedAsType @loc.outTypes) { embedAsType :: B.ByteString -> HsType embedAsType str = HsTyVar $ HsIdent ("(" ++ B.unpack str ++ ")") inhTyCon' :: Ident -> Ident -> HsName inhTyCon' nm visit = HsIdent ("Inh_" ++ show nm ++ "_" ++ show visit ++ "'") inhTyCon :: Ident -> Ident -> HsName inhTyCon nm visit = HsIdent ("Inh_" ++ show nm ++ "_" ++ show visit) synTyCon' :: Ident -> Ident -> HsName synTyCon' nm visit = HsIdent ("Syn_" ++ show nm ++ "_" ++ show visit ++ "'") synTyCon :: Ident -> Ident -> HsName synTyCon nm visit = HsIdent ("Syn_" ++ show nm ++ "_" ++ show visit) toSynName' :: Ident -> Ident -> Ident -> HsName toSynName' nm visit fld = HsIdent (show fld ++ "_Syn_" ++ show nm ++ "_" ++ show visit ++ "'") toSynName :: Ident -> Ident -> Ident -> HsName toSynName nm visit fld = HsIdent (show fld ++ "_Syn_" ++ show nm ++ "_" ++ show visit) toInhName' :: Ident -> Ident -> Ident -> HsName toInhName' nm visit fld = HsIdent (show fld ++ "_Inh_" ++ show nm ++ "_" ++ show visit ++ "'") toInhName :: Ident -> Ident -> Ident -> HsName toInhName nm visit fld = HsIdent (show fld ++ "_Inh_" ++ show nm ++ "_" ++ show visit) wrapperName' :: Ident -> Ident -> HsName wrapperName' nm visit = HsIdent ("wrap_" ++ show nm ++ "_" ++ show visit ++ "'") wrapperName :: Ident -> Ident -> HsName wrapperName nm visit = HsIdent ("wrap_" ++ show nm ++ "_" ++ show visit) unwrapperName :: Ident -> Ident -> HsName unwrapperName nm visit = HsIdent ("unwrap_" ++ show nm ++ "_" ++ show visit) semParam :: HsName semParam = HsIdent "_sem" } -- -- semantic function declaration -- ATTR Sem [ | | decl : HsDecl ] SEM Sem | Sem loc.srcLoc = posToSrcLoc @pos lhs.decl = HsPatBind @loc.srcLoc (HsPVar thisSemName) (HsUnGuardedRhs $ HsVar $ UnQual itfName) [@loc.itfCode, @loc.impSig, @loc.impCode] loc.fstVisitName = itfVisit @loc.firstVisit loc.fstVisitInps = map (toFieldHsn AtInput lhsIdent) $ itfInputs @loc.firstVisit loc.impSig = HsTypeSig @loc.srcLoc [impName] (HsQualType [] (HsTyCon $ UnQual $ visitImpTyCon @type @loc.fstVisitName)) loc.itfCode = genItf @loc.srcLoc @type @loc.fstVisitName @prods.fstVisitStatic @loc.fstVisitInps loc.impCode = HsFunBind [ HsMatch @loc.srcLoc impName (map HsPVar @loc.fstVisitInps) (HsUnGuardedRhs $ genImpCaseSequence @loc.srcLoc @prods.clauses) (genImpCases @loc.srcLoc @prods.clauses) ] { thisSemName :: HsName thisSemName = HsIdent lhsIdentStr itfName :: HsName itfName = HsIdent "__itf" impName :: HsName impName = HsIdent "__imp" impNameN :: Int -> HsName impNameN n = HsIdent ("__imp_" ++ show n) nothingQName :: HsQName nothingQName = Qual (Module "Prelude") (HsIdent "Nothing") justQName :: HsQName justQName = Qual (Module "Prelude") (HsIdent "Just") genImpCaseSequence :: SrcLoc -> [HsExp] -> HsExp genImpCaseSequence srcLoc clauses = foldr cons nil $ zipWith const [1..] clauses where nil = if null clauses then HsCon nothingQName else HsVar $ UnQual $ matchName -- pointing to a Nothing-node cons n e = HsCase (HsVar $ UnQual $ impNameN n) [ HsAlt srcLoc (HsPAsPat matchName $ HsPParen $ HsPApp justQName [HsPWildCard]) (HsUnGuardedAlt $ HsVar $ UnQual $ matchName) [] , HsAlt srcLoc (HsPAsPat matchName $ HsPParen $ HsPApp nothingQName []) (HsUnGuardedAlt $ e) [] ] genImpCases :: SrcLoc -> [HsExp] -> [HsDecl] genImpCases srcLoc = zipWith genCase [1..] where genCase n exp = HsPatBind srcLoc (HsPVar (impNameN n)) (HsUnGuardedRhs exp) [] genItf :: SrcLoc -> Ident -> Ident -> Bool -> [HsName] -> HsDecl genItf srcLoc semType visitType isStatic fstVisitInps = if isStatic then let selName = HsIdent "sel" preName = HsIdent "pre" varExps = map (HsVar . UnQual) fstVisitInps in HsPatBind srcLoc (HsPVar itfName) (HsUnGuardedRhs $ HsVar $ UnQual selName) [ HsFunBind [ HsMatch srcLoc selName ( map HsPVar fstVisitInps ) ( HsUnGuardedRhs $ wrapInNewType semType visitType $ HsCase ( foldl HsApp (HsVar $ Qual (Module "Data.Map") (HsIdent "findWithDefault")) [ HsCon nothingQName , HsTuple varExps , HsVar $ UnQual $ preName ] ) [ HsAlt srcLoc (HsPParen $ HsPApp justQName [HsPVar $ matchName]) (HsUnGuardedAlt $ HsVar $ UnQual $ matchName) [] , HsAlt srcLoc (HsPParen $ HsPApp nothingQName []) (HsUnGuardedAlt $ HsCon $ nothingQName) [] ] ) [] ] , HsPatBind srcLoc (HsPVar preName) (HsUnGuardedRhs $ HsApp (HsVar $ Qual (Module "Data.Map") (HsIdent "fromList")) (HsListComp (HsTuple [ HsTuple varExps , foldl HsApp (HsVar $ UnQual impName) varExps ]) (map (\x -> HsGenerator srcLoc (HsPVar x) (HsEnumFromTo (HsVar $ Qual (Module "Prelude") (HsIdent "minBound")) (HsVar $ Qual (Module "Prelude") (HsIdent "maxBound"))) ) fstVisitInps)) ) [] ] else HsPatBind srcLoc (HsPVar itfName) (HsUnGuardedRhs $ wrapInNewType semType visitType $ HsVar $ UnQual $ impName) [] wrapInNewType :: Ident -> Ident -> HsExp -> HsExp wrapInNewType semTp visitTp = HsParen . HsApp (HsCon $ UnQual $ visitItfTyCon semTp visitTp) } -- -- Threading of decls of the next visit -- these have to be incorporated in the current visit -- (threading from right to left) -- ATTR ProdVisits ProdVisit [ | | decls : {[HsDecl]} ] ATTR ProdVisit Clauses Clause [ nextDecls : {[HsDecl]} | | ] SEM ProdVisits | Cons lhs.decls = @hd.decls hd.nextDecls = @tl.decls | Nil lhs.decls = [] -- -- Generate itf and imp to be included in the previous visit -- SEM ProdVisit | Visit lhs.decls = [ @loc.itfDecl, @loc.impSig, @loc.impDecl ] loc.srcLoc = posToSrcLoc @pos loc.itfDecl = genItf @loc.srcLoc @lhs.semType @name @isStatic @loc.visitInputs loc.impSig = HsTypeSig @loc.srcLoc [impName] (HsQualType [] (HsTyCon $ UnQual $ visitImpTyCon @lhs.semType @name)) loc.impDecl = HsFunBind [ HsMatch @loc.srcLoc impName (map HsPVar @loc.visitInputs) (HsUnGuardedRhs $ HsCase (HsVar $ UnQual $ matchName) [ HsAlt @loc.srcLoc (HsPParen $ HsPApp justQName [HsPWildCard]) (HsUnGuardedAlt $ HsApp (HsCon $ Qual (Module "Prelude") (HsIdent "Just")) (HsTuple $ map (HsVar . UnQual) @loc.visitOutputs)) [] , HsAlt @loc.srcLoc (HsPApp nothingQName []) (HsUnGuardedAlt $ HsCon $ nothingQName) [] ]) ( [ HsPatBind @loc.srcLoc ( HsPAsPat matchName $ HsPParen $ HsPIrrPat $ HsPParen $ HsPApp justQName [ HsPTuple $ map HsPVar ( (if @lhs.isLastVisit then [] else [customItfName]) ++ @loc.commonVars)] ) (HsUnGuardedRhs $ genImpCaseSequence @loc.srcLoc @clauses.clauses) [] ] ++ genImpCases @loc.srcLoc @clauses.clauses ++ ( if @clauses.hasInternalClauses then @lhs.nextDecls else [] ) ) ] loc.visitInputs = map (toFieldHsn AtInput lhsIdent) $ itfInputs @loc.visitInfo loc.visitOutputs = (if @lhs.isLastVisit then [] else [customItfName]) ++ (map (toFieldHsn AtOutput lhsIdent) $ itfOutputs @loc.visitInfo) { matchName :: HsName matchName = HsIdent "__match" } -- -- Threading of clauses of the next visit -- (right to left) -- ATTR Prods Prod [ | | clauses USE {++} {[]} : {[HsExp]} ] ATTR ProdVisits ProdVisit [ | | clauses : {[HsExp]} ] ATTR ProdVisit Clauses Clause [ nextClauses : {[HsExp]} | | ] SEM ProdVisits | Cons hd.nextClauses = @tl.clauses lhs.clauses = @hd.clauses | Nil lhs.clauses = [] -- -- Computation of clauses -- ATTR Clauses Clause [ | | clauses USE {++} {[]} : {[HsExp]} ] SEM Clause | Internal loc.srcLoc = posToSrcLoc @pos lhs.clauses = [ HsParen $ HsLet ( [@loc.matchDecl] ++ @stmts.decls ++ if @lhs.isFirstVisit then @lhs.nextDecls else [] ++ if @lhs.isLastVisit then [] else [@loc.customItfDecl] ) ( HsParen $ HsIf (HsVar $ UnQual $ matchName) (HsParen $ HsApp (HsCon $ justQName) (HsTuple $ map (HsVar . UnQual) @loc.outputs)) (HsCon $ nothingQName) ) ] loc.outputs = if @lhs.isFirstVisit then (if @lhs.isLastVisit then [] else [itfName]) ++ (map (toFieldHsn AtOutput lhsIdent) $ itfOutputs @lhs.visitInfo) else (if @lhs.isLastVisit then [] else [customItfName]) ++ @lhs.commonVars loc.matchDecl = HsPatBind @loc.srcLoc (HsPVar matchName) (HsUnGuardedRhs $ andExpr @stmts.matchVars) [] loc.customItfDecl = HsPatBind @loc.srcLoc (HsPVar customItfName) (HsUnGuardedRhs $ HsVar $ UnQual itfName) [] | External loc.srcLoc = posToSrcLoc @pos lhs.clauses = [ HsCase (embedExp @code.output) [ HsAlt @loc.srcLoc (HsPParen $ HsPApp justQName [ HsPTuple (map HsPVar @loc.extOuts) ]) (HsUnGuardedAlt $ HsParen $ HsApp (HsCon justQName) (HsTuple $ map (HsVar . UnQual) @loc.realOuts)) [] , HsAlt @loc.srcLoc (HsPApp nothingQName []) (HsUnGuardedAlt $ HsCon nothingQName) [] ] ] loc.extOuts = (if @lhs.isLastVisit then [] else [customItfName]) ++ (map (toFieldHsn AtOutput lhsIdent) $ itfOutputs @lhs.visitInfo) loc.realOuts = if @lhs.isFirstVisit then (if @lhs.isLastVisit then [] else [customItfName]) ++ (map (toFieldHsn AtOutput lhsIdent) $ itfOutputs @lhs.visitInfo) else (if @lhs.isLastVisit then [] else [customItfName]) ++ @lhs.commonVars { andExpr :: [HsName] -> HsExp andExpr nms = HsApp (HsVar $ UnQual $ HsIdent "and") (HsList $ map (HsVar . UnQual) nms) customItfName :: HsName customItfName = HsIdent "__itf_custom" } -- -- Statement decls -- ATTR Stmts Stmt [ | | decls USE {++} {[]} : {[HsDecl]} ] SEM Stmt | Match Eval lhs.decls = [ @loc.decl ] loc.decl = HsPatBind (posToSrcLoc @pos) (HsPTuple @loc.casePats) (HsUnGuardedRhs $ embedCase @loc.outs @pat.output @expr.output @loc.caseExps @loc.caseFailExp) [] loc.pats = map HsPVar @loc.outs loc.exps = map (HsVar . UnQual) @loc.outs loc.outs = map (\(AttrOcc chld fld atClass) -> toFieldHsn atClass chld fld) $ Set.toList @pat.attrs | Match loc.caseFailExp = Just $ HsTuple ( (HsCon $ UnQual $ HsIdent "False") : replicate (length @loc.outs) (HsVar $ UnQual $ HsIdent "undefined")) loc.casePats = HsPVar @loc.matchVar : @loc.pats loc.caseExps = (HsCon $ UnQual $ HsIdent "True") : @loc.exps | Eval loc.caseFailExp = Nothing loc.casePats = @loc.pats loc.caseExps = @loc.exps SEM Stmt | ChildSem -- produces the semantics for the first visit lhs.decls = [ HsPatBind (posToSrcLoc @pos) (HsPVar $ semName @name (itfVisit @loc.firstVisitInfo)) (HsUnGuardedRhs $ embedExp @code.output) [] ] | VisitSem loc.srcLoc = posToSrcLoc @pos lhs.decls = [ @loc.trfDecl, @loc.vstDecl ] loc.trfDecl = HsPatBind @loc.srcLoc (HsPVar $ trfName @name @visit) (HsUnGuardedRhs $ embedExp @code.output) [] loc.vstDecl = HsPatBind @loc.srcLoc (HsPTuple ((maybe [] (return . HsPVar . semName @name) @loc.mbNextVisit) ++ map (HsPVar . toFieldHsn AtInput @name) (itfOutputs @loc.visitInfo))) (HsUnGuardedRhs $ HsCase (HsParen $ foldl HsApp (HsVar $ UnQual $ trfName @name @visit) ( ( HsParen $ HsCase (HsVar $ UnQual $ semName @name @visit) [ HsAlt @loc.srcLoc (HsPApp (UnQual $ visitItfTyCon @loc.type @visit) [HsPVar matchName]) (HsUnGuardedAlt $ HsVar $ UnQual matchName) [] ] ) : map (HsVar . UnQual . toFieldHsn AtOutput @name) (itfInputs @loc.visitInfo)) ) [ HsAlt @loc.srcLoc (HsPParen $ HsPApp justQName [HsPVar matchName]) (HsUnGuardedAlt $ HsVar $ UnQual $ matchName) [] , HsAlt @loc.srcLoc (HsPAsPat matchName $ HsPParen $ HsPApp nothingQName []) (HsUnGuardedAlt $ errorExp ("no clause for child " ++ show @name ++ " at " ++ show @pos)) [] ] ) [] { semName :: Ident -> Ident -> HsName semName chld vst = HsIdent ("_" ++ show chld ++ "S" ++ show vst) trfName :: Ident -> Ident -> HsName trfName chld vst = HsIdent ("_" ++ show chld ++ "X" ++ show vst) embedExp :: B.ByteString -> HsExp embedExp str = HsVar $ UnQual $ HsSymbol $ B.unpack $ B.unlines $ [ B.pack "(let {" , (B.pack "_r=") `B.append` (B.drop 3 str) , B.pack "} in _r)" ] embedCase :: [HsName] -> B.ByteString -> B.ByteString -> [HsExp] -> Maybe HsExp -> HsExp embedCase fvs pat expr rhs mbAltClause = HsVar $ UnQual $ HsSymbol $ B.unpack $ B.unlines [ B.pack "(case (let {" , (B.pack "_r=") `B.append` (B.drop 3 expr) , B.pack "} in _r) of {" , pat , (B.pack " -> ") `B.append` (ppHaskell $ HsTuple rhs) , case mbAltClause of Just e -> (B.pack "; _ -> ") `B.append` (ppHaskell e) Nothing -> B.pack " -- no failure clause" , B.pack "})" ] errorExp :: String -> HsExp errorExp s = HsApp (HsVar $ Qual (Module "Prelude") $ HsIdent "error") (HsLit $ HsString s) }