diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,23 +1,23 @@ -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - * Neither the name of the Universiteit Utrecht nor the - names of its contributors may be used to endorse or promote products - derived from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL UNIVERSITEIT UTRECHT BE LIABLE FOR ANY -DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; -LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND -ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the Universiteit Utrecht nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL UNIVERSITEIT UTRECHT BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README --- a/README +++ b/README @@ -1,19 +1,19 @@ -To install UUAG, use cabal in combination with Setup.hs - -By default, "cabal install" will install UUAGC from the -included Haskell sources. To build from the AG sources -using an existing uuagc installation, use: - -cabal install --ghc-options="-DEXTERNAL_UUAGC" - -Note: to produce a source release, you'll need to use the -Setup.hs because cabal-install at the time is not able to -do this in combination with the cabal plugin: - --- -cabal clean # remove possible junk -ghc --make Setup.hs -o setup -./setup configure --user -./setup build -./setup sdist --- +To install UUAG, use cabal in combination with Setup.hs + +By default, "cabal install" will install UUAGC from the +included Haskell sources. To build from the AG sources +using an existing uuagc installation, use: + +cabal install --ghc-options="-DEXTERNAL_UUAGC" + +Note: to produce a source release, you'll need to use the +Setup.hs because cabal-install at the time is not able to +do this in combination with the cabal plugin: + +-- +cabal clean # remove possible junk +ghc --make Setup.hs -o setup +./setup configure --user +./setup build +./setup sdist +-- diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,40 +1,40 @@ --- Note: to bootstrap uuagc with a commandline uuagc, --- pass the -DEXTERNAL_UUAGC to GHC --- when building setup.hs. This can be accomplished using --- cabal install with --ghc-options="-DEXTERNAL_UUAGC". --- --- When this option is used, a cabal flag will be set so --- that the Haskell sources will be regenerated from --- the attribute grammar sources --- --- Note: it would be nicer if this behavior could be enabled --- with a configure flag. However, a compiled Setup.hs is --- required in order to perform 'configure', so configure --- flags are regarded too late in the process. --- Also note that this Setup.hs has conditional package --- requirements depending on what code is used. - -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -{-# LANGUAGE CPP #-} -module Main where - -#ifdef EXTERNAL_UUAGC -import System.Environment (getArgs) -import Distribution.Simple (defaultMainWithHooksArgs) -import Distribution.Simple.UUAGC (uuagcUserHook) - -main :: IO () -main = args >>= defaultMainWithHooksArgs uuagcUserHook - -args :: IO [String] -args = do - as <- getArgs - let addFlags | "configure" `elem` as = ("--flags=bootstrap_external" :) - | otherwise = id - return (addFlags as) -#else -import Distribution.Simple (defaultMain, defaultMainWithHooksArgs) - -main :: IO () -main = defaultMain -#endif +-- Note: to bootstrap uuagc with a commandline uuagc, +-- pass the -DEXTERNAL_UUAGC to GHC +-- when building setup.hs. This can be accomplished using +-- cabal install with --ghc-options="-DEXTERNAL_UUAGC". +-- +-- When this option is used, a cabal flag will be set so +-- that the Haskell sources will be regenerated from +-- the attribute grammar sources +-- +-- Note: it would be nicer if this behavior could be enabled +-- with a configure flag. However, a compiled Setup.hs is +-- required in order to perform 'configure', so configure +-- flags are regarded too late in the process. +-- Also note that this Setup.hs has conditional package +-- requirements depending on what code is used. + +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# LANGUAGE CPP #-} +module Main where + +#ifdef EXTERNAL_UUAGC +import System.Environment (getArgs) +import Distribution.Simple (defaultMainWithHooksArgs) +import Distribution.Simple.UUAGC (uuagcUserHook) + +main :: IO () +main = args >>= defaultMainWithHooksArgs uuagcUserHook + +args :: IO [String] +args = do + as <- getArgs + let addFlags | "configure" `elem` as = ("--flags=bootstrap_external" :) + | otherwise = id + return (addFlags as) +#else +import Distribution.Simple (defaultMain, defaultMainWithHooksArgs) + +main :: IO () +main = defaultMain +#endif diff --git a/src-ag/AG2AspectAG.ag b/src-ag/AG2AspectAG.ag --- a/src-ag/AG2AspectAG.ag +++ b/src-ag/AG2AspectAG.ag @@ -1,857 +1,857 @@ -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "HsToken.ag" -INCLUDE "DistChildAttr.ag" - -imports -{ -import Options - -import Data.Char -import Data.List -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Maybe - -import Pretty -import PPUtil -import UU.Scanner.Position - -import AbstractSyntax -import TokenDef -import CommonTypes - --- import Debug.Trace -} - -{ -pragmaAspectAG = pp "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}" - -} - -{ -ppName l = ppListSep "" "" "_" l -} - - -ATTR Grammar [ options : Options | | ] - - -ATTR Nonterminals Nonterminal Productions Production Children Child [ o_rename : Bool | | ] -SEM Grammar - | Grammar nonts.o_rename = rename @lhs.options - -ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule [ o_noGroup : {[String]} | | ] -SEM Grammar - | Grammar loc.o_noGroup = sort $ noGroup @lhs.options - nonts.o_noGroup = @loc.o_noGroup - -SEM Nonterminal - | Nonterminal loc.inhNoGroup = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @prods.prdInh - | Nonterminal loc.synNoGroup = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @syn - - -ATTR Productions Production Children Child Rules Rule [ inhNoGroup, synNoGroup : {[String]} | | ] -SEM Nonterminal - | Nonterminal prods.inhNoGroup = map show $ Map.keys @loc.inhNoGroup - | Nonterminal prods.synNoGroup = map show $ Map.keys @loc.synNoGroup - - -SEM Productions - | Cons hd.inhNoGroup = filter (flip Map.member @hd.prdInh . identifier) @lhs.inhNoGroup - - -ATTR Productions Production Children Child [ | | prdInh USE {`Map.union`} {Map.empty} : {Attributes} ] -SEM Child - | Child lhs.prdInh = @loc.inh - - -{ -type FieldMap = [(Identifier, Type)] -type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) -} - -ATTR Grammar [ agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} | | ] - - -ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule [ newAtts : { Attributes } | | ] - -SEM Grammar | Grammar loc.newAtts = case @lhs.agi of - (_,_,atts) -> ( Map.unions . (\(a,b) -> a++b) . unzip . Map.elems) atts - nonts.newAtts = @loc.newAtts - - -ATTR Nonterminals Nonterminal [ newProds : { DataTypes } | | ] -ATTR Productions Production [ newProds : { Map.Map ConstructorIdent FieldMap } | | ] - -SEM Grammar | Grammar loc.newProds = case @lhs.agi of - (_,prods,_) -> prods - nonts.newProds = @loc.newProds - - -SEM Nonterminal - | Nonterminal prods.newProds = case Map.lookup @nt @lhs.newProds of - Just prds -> prds - Nothing -> Map.empty - - -ATTR Nonterminals Nonterminal [ newNTs : {Set NontermIdent} | | ] - -ATTR Productions Production [ | | hasMoreProds USE { || } {False} : { Bool } ] - -SEM Production | Production lhs.hasMoreProds = not $ Map.member @con @lhs.newProds - -ATTR Nonterminals Nonterminal [ | | extendedNTs USE {`Set.union`} {Set.empty} : {Set NontermIdent} ] - -SEM Nonterminal | Nonterminal lhs.extendedNTs = if @prods.hasMoreProds - then Set.singleton @nt - else Set.empty - - -SEM Grammar | Grammar nonts.newNTs = case @lhs.agi of - (newNTs,_,_) -> Set.difference newNTs @nonts.extendedNTs - - - - - -ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rules Rule [ ext : {Maybe String} | | ] - - --- IMPORT - -ATTR Grammar [ | | imp USE {>-<} {empty} : PP_Doc ] - -SEM Grammar - | Grammar lhs . imp = "import Language.Grammars.AspectAG" >-< - "import Language.Grammars.AspectAG.Derive" >-< - "import Data.HList.Label4" >-< - "import Data.HList.TypeEqGeneric1" >-< - "import Data.HList.TypeCastGeneric1" >-< - maybe empty ("import qualified" >#<) @lhs.ext >-< - maybe empty (\ext -> "import" >#< ext >#< ppListSep "(" ")" "," (@nonts.ppDI ++ @nonts.ppLI ++ @loc.ppAI ++ @loc.ppANT)) @lhs.ext - --- CODE - -ATTR Grammar [ | | pp USE {>-<} {empty} : PP_Doc ] - -SEM Grammar - | Grammar lhs . pp = (if dataTypes @lhs.options - then "-- datatypes" >-< @nonts.ppD >-< - "-- labels" >-< @nonts.ppL - else empty) - - >-< - - (if folds @lhs.options - then "-- attributes" >-< @loc.ppA >-< - "-- rules" >-< @loc.ppR >-< - "-- catas" >-< @nonts.ppCata - - else empty) - - >-< - - - (if semfuns @lhs.options - then "-- semantic functions" >-< @nonts.ppSF - else empty) - - - >-< - - (if wrappers @lhs.options - then "-- wrappers" >-< @nonts.ppW - else empty) - - - --- data definitions - -SEM Nonterminal - | Nonterminal loc . ppNt = pp @nt - -SEM Production - | Production loc . ppProd = pp @con - loc . prodName = ppName [@lhs.ppNt, @loc.ppProd] - loc . conName = if @lhs.o_rename - then @loc.prodName - else @loc.ppProd -SEM Child - | Child loc . ppCh = pp @name - loc . ppTCh = ppShow @tp - loc . chName = ppName [@loc.ppCh, @lhs.ppNt, @lhs.ppProd] - - -ATTR Productions Production Rules Rule Children Child Expression [ ppNt : PP_Doc | | ] - -SEM Nonterminal - | Nonterminal prods . ppNt = @loc.ppNt - -ATTR Rules Rule Children Child Expression [ ppProd : PP_Doc | | ] - -SEM Production - | Production children . ppProd = @loc.ppProd - rules . ppProd = @loc.ppProd - - -ATTR Nonterminals Nonterminal [ derivs : {Derivings} | | ] - -SEM Grammar - | Grammar nonts . derivs = @derivings - - -ATTR Nonterminals Nonterminal Production [ | | ppD USE {>-<} {empty} : {PP_Doc} ppDI USE {++} {[]} : {[PP_Doc]} ] - -SEM Nonterminal - | Nonterminal lhs . ppD = - if (Set.member @nt @lhs.newNTs) - then case (lookup @nt @lhs.tSyns) of - -- if it's a data type - Nothing -> "data " >|< @loc.ppNt - >|< " = " >|< vlist_sep " | " @prods.ppDL >-< - case (Map.lookup @nt @lhs.derivs) of - Just ntds -> pp " deriving " >|< (ppListSep "(" ")" ", " $ Set.elems ntds) - Nothing -> empty -- uncommented for testing purposes - -- if it's a type synonym - Just tp -> "type " >|< @loc.ppNt >|< " = " >|< ppShow tp - else empty - - lhs . ppDI = - if (not $ Set.member @nt @lhs.newNTs) - then [ @loc.ppNt ] - else [ ] --- uncommented for testing purposes - -SEM Production - | Production lhs . ppD = @loc.conName >|< ppListSep " {" "}" ", " @children.ppDL - - -ATTR Productions Children Child [ | | ppDL : {[PP_Doc]} ] - -SEM Productions - | Cons lhs . ppDL = @hd.ppD : @tl.ppDL - | Nil lhs . ppDL = [] - -SEM Children - | Cons lhs . ppDL = @hd.ppDL ++ @tl.ppDL - | Nil lhs . ppDL = [] - -SEM Child - | Child lhs . ppDL = case @kind of - ChildSyntax -> [ @loc.chName >|< pp " :: " >|< @loc.ppTCh ] - _ -> [] - - - -ATTR Nonterminals Nonterminal [ tSyns : {TypeSyns} | | ] - -SEM Grammar - | Grammar nonts . tSyns = @typeSyns - - - - --- grammar labels - - -ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppL USE {>-<} {empty} : PP_Doc ppLI USE {++} {[]} : {[PP_Doc]} ] - -SEM Nonterminal - | Nonterminal loc . ntLabel = "nt_" >|< @loc.ppNt - - lhs . ppL = ( if (Set.member @nt @lhs.newNTs) - then @loc.ntLabel >|< " = proxy :: Proxy " >|< @loc.ppNt - else empty) >-< - @prods.ppL - - lhs . ppLI = ( if (not $ Set.member @nt @lhs.newNTs) - then [ @loc.ntLabel ] - else [ ]) ++ - @prods.ppLI - -SEM Production - | Production lhs . ppL = if (Map.member @con @lhs.newProds) - then @children.ppL - else empty - - lhs . ppLI = if (not $ Map.member @con @lhs.newProds) - then @children.ppLI - else [] - - -SEM Child - | Child loc . chLabel = "ch_" >|< @loc.chName - loc . chTLabel = "Ch_" >|< @loc.chName - lhs . ppL = "data " >|< @loc.chTLabel >|< "; " >|< @loc.chLabel >|< pp " = proxy :: " >|< - case @kind of - ChildSyntax -> "Proxy " >|< "(" >|< @loc.chTLabel >|< ", " >|< @loc.ppTCh >|< ")" - _ -> "SemType " >|< @loc.ppTCh >|< pp " nt => Proxy " >|< - "(" >|< @loc.chTLabel >|< ", nt)" - - lhs . ppLI = [ @loc.chLabel, @loc.chTLabel ] - - --- attributes - - -SEM Grammar - | Grammar loc . ppA = vlist (map defAtt (filterAtts @loc.newAtts @loc.o_noGroup)) >-< -- not grouped - defAtt "loc" >-< -- local - (case @lhs.ext of - Nothing -> defAtt "inh" >-< defAtt "syn" -- grouped - otherwise -> empty) >-< - @nonts.ppA -- record definitions - - loc . ppAI = - let atts = filterNotAtts @loc.newAtts @loc.o_noGroup - in (foldr (\a as -> attName a : as) [] atts) ++ - (foldr (\a as -> attTName a : as) [] atts) ++ - (case @lhs.ext of - Nothing -> [] - otherwise -> [ attName "inh", attName "syn", attTName "inh", attTName "syn" ]) ++ - @nonts.ppAI - - - loc . ppANT = - let atts = filterNotAtts @loc.newAtts @loc.o_noGroup - in (foldr (\a as -> ("nts_" >|< a) : as) [] atts) - -ATTR Nonterminals Nonterminal Productions Production [ | | ppA USE {>-<} {empty} : PP_Doc ] - -SEM Nonterminal - | Nonterminal lhs . ppA = ( if (Set.member @nt @lhs.newNTs) - then - defAttRec (pp "InhG") @loc.ppNt @inh @loc.inhNoGroup >-< - defAttRec (pp "SynG") @loc.ppNt @syn @loc.synNoGroup - else empty) >-< - @prods.ppA - -SEM Production - | Production lhs . ppA = defLocalAtts @loc.prodName (length @rules.locals) 1 $ sort @rules.locals - - -ATTR Nonterminals Nonterminal [ | | ppAI USE {++} {[]} : {[PP_Doc]} ] - -SEM Nonterminal - | Nonterminal lhs . ppAI = if (not $ Set.member @nt @lhs.newNTs) - then [ ppName [(pp "InhG"), @loc.ppNt ] >#< pp "(..)", ppName [(pp "SynG"), @loc.ppNt ] >#< pp "(..)" ] - else [ ] - -{ -filterAtts newAtts = filter (\att -> Map.member (identifier att) newAtts) -filterNotAtts newAtts = filter (\att -> not (Map.member (identifier att) newAtts)) - -defAtt att = "data " >|< attTName att >|< "; " >|< attName att >|< " = proxy :: Proxy " >|< attTName att -attName att = pp $ "att_" ++ att -attTName att = pp $ "Att_" ++ att - - -defAttRec recPref ppNt atts noGroup = - let recName = ppName [recPref, ppNt] - fields = ppCommas (map (\(a,t) -> ppName [pp a, recName ] >|< " ::" >|< ppShow t) (groupAtts atts noGroup)) - in - "data " >|< recName >|< " = " >|< recName >|< " { " >|< fields >|< " }" - -groupAtts atts noGroup = (Map.toAscList . Map.difference atts) noGroup - --- it defines selectors with the form: --- l1_nt_prod(x, _, .., _) = x --- ln_nt_prod(_, .., _, x) = x -defLocalAtts prodName total actual (l:ls) = ppName [pp l, prodName] >|< - ppListSep "(" ")" "," (replicate (actual-1) "_" ++ "x" : replicate (total-actual) "_") >|< - pp " = x" >-< - defLocalAtts prodName total (actual+1) ls -defLocalAtts _ _ _ [] = empty - -} - - -ATTR Rules Rule [ | | locals USE {++} {[]} : {[Identifier]} ] - - -SEM Rule - | Rule lhs . locals = if (show (fst @pattern.info) == "loc") - then [ snd @pattern.info ] - else [ ] - - -ATTR Pattern [ || info : {(Identifier, Identifier)} ] -SEM Pattern - | Alias lhs . info = (@field, @attr) - | Constr lhs . info = error "Pattern Constr undefined!!" - | Product lhs . info = error "Pattern Product undefined!!" - | Underscore lhs . info = error "Pattern Underscore undefined!!" - - - --- rules - -SEM Grammar - | Grammar loc . ppNtL = @nonts.ppNtL - loc . ppR = ntsList "group" @loc.ppNtL >-< - vlist (map (\att -> ntsList att (filterNts att @loc.ppNtL)) (filterAtts @newAtts @loc.o_noGroup)) >-< - @nonts.ppR - -{ -ntsList att ppNtL = "nts_" ++ att ++ " = " >|< ppListSep "" "" " .*. " ((map fst ppNtL) ++ [pp "hNil"]) - -filterNts att = filter ( Map.member (identifier att) . snd ) -} - -ATTR Nonterminals Nonterminal [ | | ppNtL USE {++} {[]} : {[(PP_Doc, Attributes)]} ] -- list of nonterminals and its attributes - -SEM Nonterminal - | Nonterminal lhs . ppNtL = [ ("nt_" >|< @nt, Map.union @inh @syn) ] - - - - -ATTR Productions Production [ newNT : {Bool} | | ] -ATTR Rules Rule [ newProd : {Bool} | | ] - -SEM Nonterminal - | Nonterminal prods . newNT = Set.member @nt @lhs.newNTs - - -ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppR USE {>-<} {empty} : PP_Doc ] -ATTR Productions Production [ | | ppRA USE {++} {[]} : {[PP_Doc]} ] - - - - -SEM Nonterminal - | Nonterminal lhs . ppR = pp "----" >|< pp @nt >-< @prods.ppR - -SEM Production - | Production loc . newProd = Map.member @con @lhs.newProds - loc . (ppR,ppRA) - = let (instR, instRA) = defInstRules @lhs.ppNt @con @lhs.newNT @loc.newProd - @children.ppR @rules.ppRL @children.idCL @rules.locals - (locR, locRA) = defLocRule @lhs.ppNt @con @lhs.newNT @loc.newProd - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - (inhGR, inhGRA) = defInhGRule @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - (synGR, synGRA) = defSynGRule @lhs.ppNt @con @lhs.newNT @loc.newProd - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - (inhR, inhRA) = defInhRules @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - (synR, synRA) = defSynRules @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - (inhMR, inhMRA) = modInhRules @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - (synMR, synMRA) = modSynRules @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts - @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals - in ( vlist [instR,locR,inhGR,synGR,inhR,synR,inhMR,synMR] - , instRA ++ locRA ++ inhGRA ++ synGRA ++ inhMRA ++ synMRA ++ inhRA ++ synRA) - - -SEM Child - | Child lhs . ppR = let chName = ppListSep "" "" "_" [pp @name, @lhs.ppNt, @lhs.ppProd] - in pp @name >|< " <- at ch_" >|< chName - - -{ -data PPRule = PPRule Identifier Identifier Bool ([(Identifier,Type)] -> [Identifier] -> PP_Doc) - -ppRule (field,attr) owrt def = PPRule field attr owrt def -ruleField (PPRule field _ _ _ ) = field -ruleAttr (PPRule _ attr _ _ ) = attr -ruleOwrt (PPRule _ _ owrt _ ) = owrt -ruleDef (PPRule _ _ _ def) = def - -} -ATTR Rules Rule [ | | ppRL : {[ PPRule ]} ] - -SEM Rules - | Cons lhs . ppRL = @hd.ppRL ++ @tl.ppRL - | Nil lhs . ppRL = [] - -SEM Rule - | Rule lhs . ppRL = if (not @explicit && not @lhs.newProd && not (Map.member (snd @pattern.info) @lhs.newAtts) ) - then [] - else [ ppRule @pattern.info @owrt (defRule @lhs.ppNt @pattern.info @lhs.o_noGroup @rhs.ppRE) ] - -{- -ATTR Expression [ | | ppRE : {Identifier -> [String] -> [String] -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ] -SEM Expression - | Expression lhs . ppRE = rhsRule @lhs.ppNt @lhs.ppProd @tks --} - -ATTR Expression [ | | ppRE : {[String] -> Identifier -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ] -SEM Expression - | Expression lhs . ppRE = rhsRule @lhs.ppNt @lhs.ppProd @tks - - -ATTR Children Child [ || idCL USE {++} {[]} : {[(Identifier,Type)]} ] -SEM Child - | Child lhs . idCL = [ (@name, removeDeforested @tp ) ] - - - - -{ - -defInhGRule ppNt prodName newNT newProd ch rules inhNoGroup synNoGroup chids locals = - let ppAtt = ppName [pp "inh", prodName] - ppR = ppAtt >|< pp " = inhdefM att_inh nts_group $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 (foldr (>-<) (pp "emptyRecord") (map (chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals) chids)) - in if (newNT || (not newNT && newProd)) - then (ppR, [ ppAtt ]) - else (empty, []) - -chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals (idCh,tp) = - let chName = ppName [pp "ch", pp idCh, prodName] - ppTp = ppShow tp - chRules = ppCommas $ mapGRuleDefs (== idCh) rules inhNoGroup synNoGroup chids locals - in if (isNonterminal tp) - then chName >|< ".=." >-< - indent 1 "InhG_" >|< ppShow tp >|< pp " {" >-< - indent 2 chRules >-< - indent 1 "} .*. " - else empty - - -defSynGRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = - let ppAtt = ppName [pp "syn", ppNt, pp prod] - ppTAtt = "SynG_" >|< ppNt - ppR = ppAtt >|< pp " = syndefM att_syn $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 ppTAtt >|< pp " {" >-< - indent 7 (ppCommas $ mapGRuleDefs ((== "lhs") . show) rules inhNoGroup synNoGroup chids locals) >-< - indent 6 "}" - in if (newNT || (not newNT && newProd)) - then (ppR, [ ppAtt ]) - else (empty, []) - -defLocRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = - let ppAtt = ppName [pp "loc", ppNt, pp prod] - ppTAtt = ppName [pp "Loc", ppNt, pp prod] - ppR = ppAtt >|< pp " = locdefM att_loc $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 (ppListSep "(" ")" "," $ mapLRuleDefs rules inhNoGroup synNoGroup chids locals) - in (ppR, [ ppAtt ]) - -defInstRules ppNt prod newNT newProd ch rules chids locals - = let ppAsp = ppName [pp "inst", ppNt, pp prod] - instRules = filter ((=="inst") . show . ruleField) rules - ppAtt att = ppListSep "`ext` " "" "_" [pp "inst_ch", pp att, ppNt, pp prod] - in ( ppAsp >|< pp " = emptyRule " >|< (map (ppAtt . ruleAttr) instRules) >-< - (vlist $ map (defInstRule ppNt prod ch chids locals) instRules) - , [ ppAsp ]) - - -defInstRule ppNt prod ch chids locals rule = - let ppAtt = ppName [pp "ch", pp (ruleAttr rule), ppNt, pp prod] - in pp "inst_" >|< ppAtt >|< pp " = instdefM " >|< ppAtt >|< pp " $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 ((ruleDef rule) chids locals) - - -defSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals - = let synRules = filter ( (=="lhs") . show . ruleField) rules - ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules - (ppR, ppRA) = unzip $ map (defSynRule True ppNt prod newNT newProd newAtts ch chids locals) ngRules - in (vlist ppR, concat ppRA ) - -modSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals - = let synRules = filter ( (=="lhs") . show . ruleField) rules - ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules - (ppR, ppRA) = unzip $ map (defSynRule False ppNt prod newNT newProd newAtts ch chids locals) ngRules - in (vlist ppR, concat ppRA ) - -defSynRule new ppNt prod newNT newProd newAtts ch chids locals rule = - let att = ruleAttr rule - newAtt = Map.member att newAtts - owrt = ruleOwrt rule - ppAtt = ppName [pp att, pp (if new then "syn" else "synM"), ppNt, pp prod] - ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName (show att) >|< pp " $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 ((ruleDef rule) chids locals) - in - if new - then if (not owrt && (newNT || (not newNT && newProd) || newAtt)) - then (ppR "syndefM", [ ppAtt ]) - else (empty, []) - else if owrt - then (ppR "synmodM", [ ppAtt ]) - else (empty, []) - - - -defInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals - = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules - (ppR, ppRA) = unzip $ map (defInhRule True ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup - in (vlist ppR, concat ppRA) - -modInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals - = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules - (ppR, ppRA) = unzip $ map (defInhRule False ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup - in (vlist ppR, concat ppRA) - - -defInhRule new ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals att = - let ppAtt = ppName [pp att, pp (if new then "inh" else "inhM"),prodName] - newAtt = Map.member (identifier att) newAtts - chRMaybe = map (chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals) chids - chR = [ x | (Just x) <- chRMaybe ] - ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName att >|< " nts_" >|< att >|< " $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 (foldr (>-<) (pp "emptyRecord") chR) - in - if new - then if (newNT || (not newNT && newProd) || newAtt) - then (ppR "inhdefM", [ ppAtt ]) - else (empty, []) - else if (not . null) chR - then (ppR "inhmodM", [ ppAtt ]) - else (empty, []) - - -chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals (idCh,tp) = - let chName = ppName [pp "ch", pp idCh, prodName] - ppTp = ppShow tp - chRule = inhRuleDef new (== idCh) (== att) rules inhNoGroup synNoGroup chids locals -- it's supposed to be only one - in if (isNonterminal tp && (not . null) chRule) - then Just $ chName >|< ".=. (" >|< chRule >|< ") .*. " - else Nothing - - -mapLRuleDefs rules inhNoGroup synNoGroup chids locals - = map appSnd $ sortBy cmpField $ filter ((== "loc") . show . ruleField) rules - where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) - appSnd rule = (ruleDef rule) chids locals - - -mapGRuleDefs filt rules inhNoGroup synNoGroup chids locals - = map appSnd $ sortBy cmpField $ filter (not . (flip elem inhNoGroup) . getName . ruleAttr) - $ filter (not . (flip elem synNoGroup) . getName . ruleAttr) - $ filter ( filt . ruleField) rules - where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) - appSnd rule = (ruleDef rule) chids locals - -inhRuleDef new filt1 filt2 rules inhNoGroup synNoGroup chids locals - = map appSnd $ sortBy cmpField $ filter ( (== not new) . ruleOwrt) - $ filter ((flip elem inhNoGroup) . getName . ruleAttr) - $ filter ( filt2 . getName . ruleAttr) - $ filter ( filt1 . ruleField) rules - where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) - appSnd rule = (ruleDef rule) chids locals - -defRule ppNt (field,att) noGroup rhs = \chids locals -> - let ppAtt = if (elem (getName att) noGroup) - then empty - else case (show field) of - "lhs" -> att >|< "_" >|< pp "SynG" >|< pp "_" >|< ppNt >|< " = " - "loc" -> empty - "inst" -> empty - otherwise -> att >|< "_" >|< pp "InhG" >|< pp "_" >|< - (maybe (error $ "lhs field " ++ show field ++" is not a child") - ppShow (lookup field chids)) - >|< " = " - in ppAtt >|< (rhs noGroup field chids locals) - - -rhsRule ppNt ppProd tks noGroup field chids locals = vlist . lines2PP . (map (token2PP ppNt ppProd field chids locals noGroup )) $ tks - - -lines2PP [] = [] -lines2PP xs = map line2PP . shiftLeft . getLines $ xs - - -token2PP ppNt ppProd field chids locals noGroup tk - = case tk of - AGLocal var pos _ -> (pos, if (elem var locals) - then (ppListSep "(" "" "_" [pp var, ppNt, ppProd]) >|< pp " (loc # att_loc)) " - else pp var) - AGField field attr pos _ -> let ppChT = maybe (error $ "rhs field " ++ show field ++ " is not a child") ppShow (lookup field chids) - ppAtt = case (show field) of - "lhs" -> attName "inh" - "loc" -> attName "loc" - otherwise -> attName "syn" - ppSubAtt = case (show field) of - "lhs" -> ppName [pp (getName attr), pp "InhG", ppNt] - "loc" -> ppName [pp (getName attr), ppNt, ppProd] - otherwise -> ppName [pp (getName attr), pp "SynG", ppChT] - in (pos, if ((elem (getName attr) noGroup) && ((show field) /= "loc")) - then pp "(" >|< pp (getName field) >|< " # " >|< attName (getName attr) >|< pp ")" - else pp "(" >|< ppSubAtt >|< " (" >|< pp (getName field) >|< " # " >|< ppAtt >|< ")) ") - HsToken value pos -> (pos, pp value) - CharToken value pos -> (pos, pp (show value)) - StrToken value pos -> (pos, pp (show value)) - Err mesg pos -> (pos, pp $ " ***" ++ mesg ++ "*** ") - -line2PP ts = let f (p,t) r = let ct = column p - in \c -> pp (spaces (ct-c)) >|< t >|< r (length (show t) +ct) - spaces x | x < 0 = "" - | otherwise = replicate x ' ' - in foldr f (pp . const "") ts 1 - -} - ----------------------------------------------------------------------------------------------------------------------------------------------- - - -{ -ppMacro (Macro con children) = "( atts_" >|< show con >|< ", " >|< ppListSep "" "" " <.> " ppChildren >|<")" - where ppChildren = map ppChild children - ppChild (RuleChild ch n) = chName ch >|< " ==> " >|< ppMacro n - ppChild (ChildChild ch n) = chName ch >|< " --> " >|< n - ppChild (ValueChild ch n) = chName ch >|< " ~~> " >|< n - chName ch = ppName [pp "ch", pp ch, pp con] -} - --- catamorphisms - -ATTR Nonterminals Nonterminal Productions Production [ | | ppCata USE {>-<} {empty} : PP_Doc ] - -SEM Nonterminal - | Nonterminal lhs . ppCata = "----" >|< @loc.ppNt >-< @prods.ppCata - - -SEM Production - | Production lhs . ppCata = - let extend = maybe [] - ( \ext -> if (@lhs.newNT || (not @lhs.newNT && @loc.newProd)) - then [] - else [ ext >|< ".atts_" >|< @loc.prodName ]) - @lhs.ext - macro = case @macro of - Nothing -> [] - Just macro -> [ "agMacro " >|< ppMacro macro ] - atts = sortBy (\a b -> compare (show a) (show b)) @loc.ppRA - in "atts_" >|< @loc.prodName >|< " = " >|< - ppListSep "" "" " `ext` " - (atts ++ macro ++ extend ) >-< - "semP_" >|< @loc.prodName >|< pp " = knit atts_" >|< @loc.prodName - -{ -ppNoGroupAtts syn noGroup = let synatts = Map.keys $ Map.filterWithKey (\att _ -> elem (getName att) noGroup) syn - in map (flip (>|<) "_inh") noGroup ++ map (flip (>|<) "_syn") synatts - -ruleName att prodName = ppName [att,prodName] - -elemNT a b = False -} - -ATTR Productions Production [ syn, inh : { Attributes } | | ] - -SEM Nonterminal - | Nonterminal prods . syn = @syn - prods . inh = @inh - - - --- semantic functions - -ATTR Nonterminals Nonterminal Productions Production [ | | ppSF USE {>-<} {empty} : PP_Doc ] -ATTR Productions Production [ | | ppSPF USE {>-<} {empty} : PP_Doc ] - - -SEM Nonterminal - | Nonterminal lhs . ppSF = - let inhAtts = attTypes @loc.inhNoGroup - synAtts = attTypes @loc.synNoGroup - in - "----" >|< @loc.ppNt >-< - "type T_" >|< @loc.ppNt >|< " = " >|< - "(Record " >|< - inhAtts >|< - "(HCons (LVPair (Proxy Att_inh) InhG_" >|< @loc.ppNt >|< ") HNil))" >|< - replicate (length inhAtts) ")" >|< " -> " >|< - "(Record " >|< - synAtts >|< - "(HCons (LVPair (Proxy Att_syn) SynG_" >|< @loc.ppNt >|< ") HNil))" >|< - replicate (length synAtts) ")" >-< - "-- instance SemType T_" >|< @loc.ppNt >|< " " >|< @loc.ppNt >-< - "-- sem_" >|< @loc.ppNt >|< " :: " >|< @loc.ppNt >|< " -> T_" >|< @loc.ppNt >-< - @prods.ppSPF -- >-< - -- @prods.ppSF - -{ -attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts -} - - -SEM Production - | Production lhs . ppSF = - let chi = @children.ppCSF - ppPattern = case (show @con) of - -- hardcoded list support - "Cons" -> ppParams (ppListSep "" "" " : ") - "Nil" -> pp "[]" - -- general case - otherwise -> @loc.conName >|< " " >|< (ppParams ppSpaced) - - ppParams f = f $ map (((>|<) (pp "_")) . fst) chi - in "sem_" >|< @lhs.ppNt >|< " (" >|< ppPattern >|< ") = sem_" >|< @loc.prodName >|< - " (" >|< map (fst . snd) chi >|< "emptyRecord)" - lhs . ppSPF = - let chi = @children.ppCSF - ppParams f = f $ map (((>|<) (pp "_")) . fst) chi - in "sem_" >|< @lhs.ppNt >|< "_" >|< @con >#< ppParams ppSpaced >|< " = semP_" >|< @loc.prodName >|< - " (" >|< map (snd . snd) chi >|< "emptyRecord)" - - -ATTR Children Child [ | | ppCSF USE {++} {[]} : {[(Identifier,(PP_Doc,PP_Doc))]} ] - - -SEM Child - | Child lhs . ppCSF = - let - semC = if (isNonterminal @tp) - then "sem_" >|< ppShow @tp >|< " _" >|< @name - else "sem_Lit _" >|< @name - in case @kind of - ChildSyntax -> [(@name, ( @loc.chLabel >|< " .=. (" >|< semC >|< ") .*. " - , @loc.chLabel >|< " .=. _" >|< @name >|< " .*. "))] - _ -> [] - - - - --- wrappers - ---TODO: create the records Inh_nt and Syn_nt to wrap the attributes - -ATTR Nonterminals Nonterminal [ | | ppW USE {>-<} {empty} : PP_Doc ] - -SEM Nonterminal - | Nonterminal lhs . ppW = - ppName [pp "wrap", @loc.ppNt] >|< " sem " >|< attVars @inh >|< " = " >-< - " sem " >|< attFields @inh @loc.inhNoGroup @loc.ppNt - - -{ -attVars atts = map (\(a,_) -> "_" >|< a >|< " ") $ Map.toAscList atts -attFields atts noGroup ppNt = - let ng = map (\(a,_) -> attName (getName a) >|< " .=. _" >|< a >|< " .*. ") $ Map.toAscList noGroup - g = ppCommas $ map (\(a,_) -> ppName [pp a, pp "InhG",ppNt] >|< "= _" >|< a) $ Map.toAscList $ Map.difference atts noGroup - in "(" >|< ng >|< "att_inh .=. " >|< ppName [pp "InhG", ppNt] >|< " { " >|< g >|< " } .*. emptyRecord)" -} +INCLUDE "AbstractSyntax.ag" +INCLUDE "Patterns.ag" +INCLUDE "Expression.ag" +INCLUDE "HsToken.ag" +INCLUDE "DistChildAttr.ag" + +imports +{ +import Options + +import Data.Char +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Maybe + +import Pretty +import PPUtil +import UU.Scanner.Position + +import AbstractSyntax +import TokenDef +import CommonTypes + +-- import Debug.Trace +} + +{ +pragmaAspectAG = pp "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}" + +} + +{ +ppName l = ppListSep "" "" "_" l +} + + +ATTR Grammar [ options : Options | | ] + + +ATTR Nonterminals Nonterminal Productions Production Children Child [ o_rename : Bool | | ] +SEM Grammar + | Grammar nonts.o_rename = rename @lhs.options + +ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule [ o_noGroup : {[String]} | | ] +SEM Grammar + | Grammar loc.o_noGroup = sort $ noGroup @lhs.options + nonts.o_noGroup = @loc.o_noGroup + +SEM Nonterminal + | Nonterminal loc.inhNoGroup = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @prods.prdInh + | Nonterminal loc.synNoGroup = Map.filterWithKey (\att _ -> elem (getName att) @lhs.o_noGroup) @syn + + +ATTR Productions Production Children Child Rules Rule [ inhNoGroup, synNoGroup : {[String]} | | ] +SEM Nonterminal + | Nonterminal prods.inhNoGroup = map show $ Map.keys @loc.inhNoGroup + | Nonterminal prods.synNoGroup = map show $ Map.keys @loc.synNoGroup + + +SEM Productions + | Cons hd.inhNoGroup = filter (flip Map.member @hd.prdInh . identifier) @lhs.inhNoGroup + + +ATTR Productions Production Children Child [ | | prdInh USE {`Map.union`} {Map.empty} : {Attributes} ] +SEM Child + | Child lhs.prdInh = @loc.inh + + +{ +type FieldMap = [(Identifier, Type)] +type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) +} + +ATTR Grammar [ agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} | | ] + + +ATTR Nonterminals Nonterminal Productions Production Children Child Rules Rule [ newAtts : { Attributes } | | ] + +SEM Grammar | Grammar loc.newAtts = case @lhs.agi of + (_,_,atts) -> ( Map.unions . (\(a,b) -> a++b) . unzip . Map.elems) atts + nonts.newAtts = @loc.newAtts + + +ATTR Nonterminals Nonterminal [ newProds : { DataTypes } | | ] +ATTR Productions Production [ newProds : { Map.Map ConstructorIdent FieldMap } | | ] + +SEM Grammar | Grammar loc.newProds = case @lhs.agi of + (_,prods,_) -> prods + nonts.newProds = @loc.newProds + + +SEM Nonterminal + | Nonterminal prods.newProds = case Map.lookup @nt @lhs.newProds of + Just prds -> prds + Nothing -> Map.empty + + +ATTR Nonterminals Nonterminal [ newNTs : {Set NontermIdent} | | ] + +ATTR Productions Production [ | | hasMoreProds USE { || } {False} : { Bool } ] + +SEM Production | Production lhs.hasMoreProds = not $ Map.member @con @lhs.newProds + +ATTR Nonterminals Nonterminal [ | | extendedNTs USE {`Set.union`} {Set.empty} : {Set NontermIdent} ] + +SEM Nonterminal | Nonterminal lhs.extendedNTs = if @prods.hasMoreProds + then Set.singleton @nt + else Set.empty + + +SEM Grammar | Grammar nonts.newNTs = case @lhs.agi of + (newNTs,_,_) -> Set.difference newNTs @nonts.extendedNTs + + + + + +ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rules Rule [ ext : {Maybe String} | | ] + + +-- IMPORT + +ATTR Grammar [ | | imp USE {>-<} {empty} : PP_Doc ] + +SEM Grammar + | Grammar lhs . imp = "import Language.Grammars.AspectAG" >-< + "import Language.Grammars.AspectAG.Derive" >-< + "import Data.HList.Label4" >-< + "import Data.HList.TypeEqGeneric1" >-< + "import Data.HList.TypeCastGeneric1" >-< + maybe empty ("import qualified" >#<) @lhs.ext >-< + maybe empty (\ext -> "import" >#< ext >#< ppListSep "(" ")" "," (@nonts.ppDI ++ @nonts.ppLI ++ @loc.ppAI ++ @loc.ppANT)) @lhs.ext + +-- CODE + +ATTR Grammar [ | | pp USE {>-<} {empty} : PP_Doc ] + +SEM Grammar + | Grammar lhs . pp = (if dataTypes @lhs.options + then "-- datatypes" >-< @nonts.ppD >-< + "-- labels" >-< @nonts.ppL + else empty) + + >-< + + (if folds @lhs.options + then "-- attributes" >-< @loc.ppA >-< + "-- rules" >-< @loc.ppR >-< + "-- catas" >-< @nonts.ppCata + + else empty) + + >-< + + + (if semfuns @lhs.options + then "-- semantic functions" >-< @nonts.ppSF + else empty) + + + >-< + + (if wrappers @lhs.options + then "-- wrappers" >-< @nonts.ppW + else empty) + + + +-- data definitions + +SEM Nonterminal + | Nonterminal loc . ppNt = pp @nt + +SEM Production + | Production loc . ppProd = pp @con + loc . prodName = ppName [@lhs.ppNt, @loc.ppProd] + loc . conName = if @lhs.o_rename + then @loc.prodName + else @loc.ppProd +SEM Child + | Child loc . ppCh = pp @name + loc . ppTCh = ppShow @tp + loc . chName = ppName [@loc.ppCh, @lhs.ppNt, @lhs.ppProd] + + +ATTR Productions Production Rules Rule Children Child Expression [ ppNt : PP_Doc | | ] + +SEM Nonterminal + | Nonterminal prods . ppNt = @loc.ppNt + +ATTR Rules Rule Children Child Expression [ ppProd : PP_Doc | | ] + +SEM Production + | Production children . ppProd = @loc.ppProd + rules . ppProd = @loc.ppProd + + +ATTR Nonterminals Nonterminal [ derivs : {Derivings} | | ] + +SEM Grammar + | Grammar nonts . derivs = @derivings + + +ATTR Nonterminals Nonterminal Production [ | | ppD USE {>-<} {empty} : {PP_Doc} ppDI USE {++} {[]} : {[PP_Doc]} ] + +SEM Nonterminal + | Nonterminal lhs . ppD = + if (Set.member @nt @lhs.newNTs) + then case (lookup @nt @lhs.tSyns) of + -- if it's a data type + Nothing -> "data " >|< @loc.ppNt + >|< " = " >|< vlist_sep " | " @prods.ppDL >-< + case (Map.lookup @nt @lhs.derivs) of + Just ntds -> pp " deriving " >|< (ppListSep "(" ")" ", " $ Set.elems ntds) + Nothing -> empty -- uncommented for testing purposes + -- if it's a type synonym + Just tp -> "type " >|< @loc.ppNt >|< " = " >|< ppShow tp + else empty + + lhs . ppDI = + if (not $ Set.member @nt @lhs.newNTs) + then [ @loc.ppNt ] + else [ ] +-- uncommented for testing purposes + +SEM Production + | Production lhs . ppD = @loc.conName >|< ppListSep " {" "}" ", " @children.ppDL + + +ATTR Productions Children Child [ | | ppDL : {[PP_Doc]} ] + +SEM Productions + | Cons lhs . ppDL = @hd.ppD : @tl.ppDL + | Nil lhs . ppDL = [] + +SEM Children + | Cons lhs . ppDL = @hd.ppDL ++ @tl.ppDL + | Nil lhs . ppDL = [] + +SEM Child + | Child lhs . ppDL = case @kind of + ChildSyntax -> [ @loc.chName >|< pp " :: " >|< @loc.ppTCh ] + _ -> [] + + + +ATTR Nonterminals Nonterminal [ tSyns : {TypeSyns} | | ] + +SEM Grammar + | Grammar nonts . tSyns = @typeSyns + + + + +-- grammar labels + + +ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppL USE {>-<} {empty} : PP_Doc ppLI USE {++} {[]} : {[PP_Doc]} ] + +SEM Nonterminal + | Nonterminal loc . ntLabel = "nt_" >|< @loc.ppNt + + lhs . ppL = ( if (Set.member @nt @lhs.newNTs) + then @loc.ntLabel >|< " = proxy :: Proxy " >|< @loc.ppNt + else empty) >-< + @prods.ppL + + lhs . ppLI = ( if (not $ Set.member @nt @lhs.newNTs) + then [ @loc.ntLabel ] + else [ ]) ++ + @prods.ppLI + +SEM Production + | Production lhs . ppL = if (Map.member @con @lhs.newProds) + then @children.ppL + else empty + + lhs . ppLI = if (not $ Map.member @con @lhs.newProds) + then @children.ppLI + else [] + + +SEM Child + | Child loc . chLabel = "ch_" >|< @loc.chName + loc . chTLabel = "Ch_" >|< @loc.chName + lhs . ppL = "data " >|< @loc.chTLabel >|< "; " >|< @loc.chLabel >|< pp " = proxy :: " >|< + case @kind of + ChildSyntax -> "Proxy " >|< "(" >|< @loc.chTLabel >|< ", " >|< @loc.ppTCh >|< ")" + _ -> "SemType " >|< @loc.ppTCh >|< pp " nt => Proxy " >|< + "(" >|< @loc.chTLabel >|< ", nt)" + + lhs . ppLI = [ @loc.chLabel, @loc.chTLabel ] + + +-- attributes + + +SEM Grammar + | Grammar loc . ppA = vlist (map defAtt (filterAtts @loc.newAtts @loc.o_noGroup)) >-< -- not grouped + defAtt "loc" >-< -- local + (case @lhs.ext of + Nothing -> defAtt "inh" >-< defAtt "syn" -- grouped + otherwise -> empty) >-< + @nonts.ppA -- record definitions + + loc . ppAI = + let atts = filterNotAtts @loc.newAtts @loc.o_noGroup + in (foldr (\a as -> attName a : as) [] atts) ++ + (foldr (\a as -> attTName a : as) [] atts) ++ + (case @lhs.ext of + Nothing -> [] + otherwise -> [ attName "inh", attName "syn", attTName "inh", attTName "syn" ]) ++ + @nonts.ppAI + + + loc . ppANT = + let atts = filterNotAtts @loc.newAtts @loc.o_noGroup + in (foldr (\a as -> ("nts_" >|< a) : as) [] atts) + +ATTR Nonterminals Nonterminal Productions Production [ | | ppA USE {>-<} {empty} : PP_Doc ] + +SEM Nonterminal + | Nonterminal lhs . ppA = ( if (Set.member @nt @lhs.newNTs) + then + defAttRec (pp "InhG") @loc.ppNt @inh @loc.inhNoGroup >-< + defAttRec (pp "SynG") @loc.ppNt @syn @loc.synNoGroup + else empty) >-< + @prods.ppA + +SEM Production + | Production lhs . ppA = defLocalAtts @loc.prodName (length @rules.locals) 1 $ sort @rules.locals + + +ATTR Nonterminals Nonterminal [ | | ppAI USE {++} {[]} : {[PP_Doc]} ] + +SEM Nonterminal + | Nonterminal lhs . ppAI = if (not $ Set.member @nt @lhs.newNTs) + then [ ppName [(pp "InhG"), @loc.ppNt ] >#< pp "(..)", ppName [(pp "SynG"), @loc.ppNt ] >#< pp "(..)" ] + else [ ] + +{ +filterAtts newAtts = filter (\att -> Map.member (identifier att) newAtts) +filterNotAtts newAtts = filter (\att -> not (Map.member (identifier att) newAtts)) + +defAtt att = "data " >|< attTName att >|< "; " >|< attName att >|< " = proxy :: Proxy " >|< attTName att +attName att = pp $ "att_" ++ att +attTName att = pp $ "Att_" ++ att + + +defAttRec recPref ppNt atts noGroup = + let recName = ppName [recPref, ppNt] + fields = ppCommas (map (\(a,t) -> ppName [pp a, recName ] >|< " ::" >|< ppShow t) (groupAtts atts noGroup)) + in + "data " >|< recName >|< " = " >|< recName >|< " { " >|< fields >|< " }" + +groupAtts atts noGroup = (Map.toAscList . Map.difference atts) noGroup + +-- it defines selectors with the form: +-- l1_nt_prod(x, _, .., _) = x +-- ln_nt_prod(_, .., _, x) = x +defLocalAtts prodName total actual (l:ls) = ppName [pp l, prodName] >|< + ppListSep "(" ")" "," (replicate (actual-1) "_" ++ "x" : replicate (total-actual) "_") >|< + pp " = x" >-< + defLocalAtts prodName total (actual+1) ls +defLocalAtts _ _ _ [] = empty + +} + + +ATTR Rules Rule [ | | locals USE {++} {[]} : {[Identifier]} ] + + +SEM Rule + | Rule lhs . locals = if (show (fst @pattern.info) == "loc") + then [ snd @pattern.info ] + else [ ] + + +ATTR Pattern [ || info : {(Identifier, Identifier)} ] +SEM Pattern + | Alias lhs . info = (@field, @attr) + | Constr lhs . info = error "Pattern Constr undefined!!" + | Product lhs . info = error "Pattern Product undefined!!" + | Underscore lhs . info = error "Pattern Underscore undefined!!" + + + +-- rules + +SEM Grammar + | Grammar loc . ppNtL = @nonts.ppNtL + loc . ppR = ntsList "group" @loc.ppNtL >-< + vlist (map (\att -> ntsList att (filterNts att @loc.ppNtL)) (filterAtts @newAtts @loc.o_noGroup)) >-< + @nonts.ppR + +{ +ntsList att ppNtL = "nts_" ++ att ++ " = " >|< ppListSep "" "" " .*. " ((map fst ppNtL) ++ [pp "hNil"]) + +filterNts att = filter ( Map.member (identifier att) . snd ) +} + +ATTR Nonterminals Nonterminal [ | | ppNtL USE {++} {[]} : {[(PP_Doc, Attributes)]} ] -- list of nonterminals and its attributes + +SEM Nonterminal + | Nonterminal lhs . ppNtL = [ ("nt_" >|< @nt, Map.union @inh @syn) ] + + + + +ATTR Productions Production [ newNT : {Bool} | | ] +ATTR Rules Rule [ newProd : {Bool} | | ] + +SEM Nonterminal + | Nonterminal prods . newNT = Set.member @nt @lhs.newNTs + + +ATTR Nonterminals Nonterminal Productions Production Children Child [ | | ppR USE {>-<} {empty} : PP_Doc ] +ATTR Productions Production [ | | ppRA USE {++} {[]} : {[PP_Doc]} ] + + + + +SEM Nonterminal + | Nonterminal lhs . ppR = pp "----" >|< pp @nt >-< @prods.ppR + +SEM Production + | Production loc . newProd = Map.member @con @lhs.newProds + loc . (ppR,ppRA) + = let (instR, instRA) = defInstRules @lhs.ppNt @con @lhs.newNT @loc.newProd + @children.ppR @rules.ppRL @children.idCL @rules.locals + (locR, locRA) = defLocRule @lhs.ppNt @con @lhs.newNT @loc.newProd + @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals + (inhGR, inhGRA) = defInhGRule @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd + @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals + (synGR, synGRA) = defSynGRule @lhs.ppNt @con @lhs.newNT @loc.newProd + @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals + (inhR, inhRA) = defInhRules @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts + @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals + (synR, synRA) = defSynRules @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts + @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals + (inhMR, inhMRA) = modInhRules @lhs.ppNt @loc.prodName @lhs.newNT @loc.newProd @lhs.newAtts + @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals + (synMR, synMRA) = modSynRules @lhs.ppNt @con @lhs.newNT @loc.newProd @lhs.newAtts + @children.ppR @rules.ppRL @lhs.inhNoGroup @lhs.synNoGroup @children.idCL @rules.locals + in ( vlist [instR,locR,inhGR,synGR,inhR,synR,inhMR,synMR] + , instRA ++ locRA ++ inhGRA ++ synGRA ++ inhMRA ++ synMRA ++ inhRA ++ synRA) + + +SEM Child + | Child lhs . ppR = let chName = ppListSep "" "" "_" [pp @name, @lhs.ppNt, @lhs.ppProd] + in pp @name >|< " <- at ch_" >|< chName + + +{ +data PPRule = PPRule Identifier Identifier Bool ([(Identifier,Type)] -> [Identifier] -> PP_Doc) + +ppRule (field,attr) owrt def = PPRule field attr owrt def +ruleField (PPRule field _ _ _ ) = field +ruleAttr (PPRule _ attr _ _ ) = attr +ruleOwrt (PPRule _ _ owrt _ ) = owrt +ruleDef (PPRule _ _ _ def) = def + +} +ATTR Rules Rule [ | | ppRL : {[ PPRule ]} ] + +SEM Rules + | Cons lhs . ppRL = @hd.ppRL ++ @tl.ppRL + | Nil lhs . ppRL = [] + +SEM Rule + | Rule lhs . ppRL = if (not @explicit && not @lhs.newProd && not (Map.member (snd @pattern.info) @lhs.newAtts) ) + then [] + else [ ppRule @pattern.info @owrt (defRule @lhs.ppNt @pattern.info @lhs.o_noGroup @rhs.ppRE) ] + +{- +ATTR Expression [ | | ppRE : {Identifier -> [String] -> [String] -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ] +SEM Expression + | Expression lhs . ppRE = rhsRule @lhs.ppNt @lhs.ppProd @tks +-} + +ATTR Expression [ | | ppRE : {[String] -> Identifier -> [(Identifier,Type)] -> [Identifier] -> PP_Doc} ] +SEM Expression + | Expression lhs . ppRE = rhsRule @lhs.ppNt @lhs.ppProd @tks + + +ATTR Children Child [ || idCL USE {++} {[]} : {[(Identifier,Type)]} ] +SEM Child + | Child lhs . idCL = [ (@name, removeDeforested @tp ) ] + + + + +{ + +defInhGRule ppNt prodName newNT newProd ch rules inhNoGroup synNoGroup chids locals = + let ppAtt = ppName [pp "inh", prodName] + ppR = ppAtt >|< pp " = inhdefM att_inh nts_group $" >-< + indent 4 "do " >-< + indent 5 "loc <- at loc" >-< + indent 5 "lhs <- at lhs" >-< + indent 5 ch >-< + indent 5 "return $" >-< + indent 6 (foldr (>-<) (pp "emptyRecord") (map (chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals) chids)) + in if (newNT || (not newNT && newProd)) + then (ppR, [ ppAtt ]) + else (empty, []) + +chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals (idCh,tp) = + let chName = ppName [pp "ch", pp idCh, prodName] + ppTp = ppShow tp + chRules = ppCommas $ mapGRuleDefs (== idCh) rules inhNoGroup synNoGroup chids locals + in if (isNonterminal tp) + then chName >|< ".=." >-< + indent 1 "InhG_" >|< ppShow tp >|< pp " {" >-< + indent 2 chRules >-< + indent 1 "} .*. " + else empty + + +defSynGRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = + let ppAtt = ppName [pp "syn", ppNt, pp prod] + ppTAtt = "SynG_" >|< ppNt + ppR = ppAtt >|< pp " = syndefM att_syn $" >-< + indent 4 "do " >-< + indent 5 "loc <- at loc" >-< + indent 5 "lhs <- at lhs" >-< + indent 5 ch >-< + indent 5 "return $" >-< + indent 6 ppTAtt >|< pp " {" >-< + indent 7 (ppCommas $ mapGRuleDefs ((== "lhs") . show) rules inhNoGroup synNoGroup chids locals) >-< + indent 6 "}" + in if (newNT || (not newNT && newProd)) + then (ppR, [ ppAtt ]) + else (empty, []) + +defLocRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = + let ppAtt = ppName [pp "loc", ppNt, pp prod] + ppTAtt = ppName [pp "Loc", ppNt, pp prod] + ppR = ppAtt >|< pp " = locdefM att_loc $" >-< + indent 4 "do " >-< + indent 5 "loc <- at loc" >-< + indent 5 "lhs <- at lhs" >-< + indent 5 ch >-< + indent 5 "return $" >-< + indent 6 (ppListSep "(" ")" "," $ mapLRuleDefs rules inhNoGroup synNoGroup chids locals) + in (ppR, [ ppAtt ]) + +defInstRules ppNt prod newNT newProd ch rules chids locals + = let ppAsp = ppName [pp "inst", ppNt, pp prod] + instRules = filter ((=="inst") . show . ruleField) rules + ppAtt att = ppListSep "`ext` " "" "_" [pp "inst_ch", pp att, ppNt, pp prod] + in ( ppAsp >|< pp " = emptyRule " >|< (map (ppAtt . ruleAttr) instRules) >-< + (vlist $ map (defInstRule ppNt prod ch chids locals) instRules) + , [ ppAsp ]) + + +defInstRule ppNt prod ch chids locals rule = + let ppAtt = ppName [pp "ch", pp (ruleAttr rule), ppNt, pp prod] + in pp "inst_" >|< ppAtt >|< pp " = instdefM " >|< ppAtt >|< pp " $" >-< + indent 4 "do " >-< + indent 5 "loc <- at loc" >-< + indent 5 "lhs <- at lhs" >-< + indent 5 ch >-< + indent 5 "return $" >-< + indent 6 ((ruleDef rule) chids locals) + + +defSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals + = let synRules = filter ( (=="lhs") . show . ruleField) rules + ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules + (ppR, ppRA) = unzip $ map (defSynRule True ppNt prod newNT newProd newAtts ch chids locals) ngRules + in (vlist ppR, concat ppRA ) + +modSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals + = let synRules = filter ( (=="lhs") . show . ruleField) rules + ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules + (ppR, ppRA) = unzip $ map (defSynRule False ppNt prod newNT newProd newAtts ch chids locals) ngRules + in (vlist ppR, concat ppRA ) + +defSynRule new ppNt prod newNT newProd newAtts ch chids locals rule = + let att = ruleAttr rule + newAtt = Map.member att newAtts + owrt = ruleOwrt rule + ppAtt = ppName [pp att, pp (if new then "syn" else "synM"), ppNt, pp prod] + ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName (show att) >|< pp " $" >-< + indent 4 "do " >-< + indent 5 "loc <- at loc" >-< + indent 5 "lhs <- at lhs" >-< + indent 5 ch >-< + indent 5 "return $" >-< + indent 6 ((ruleDef rule) chids locals) + in + if new + then if (not owrt && (newNT || (not newNT && newProd) || newAtt)) + then (ppR "syndefM", [ ppAtt ]) + else (empty, []) + else if owrt + then (ppR "synmodM", [ ppAtt ]) + else (empty, []) + + + +defInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals + = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules + (ppR, ppRA) = unzip $ map (defInhRule True ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup + in (vlist ppR, concat ppRA) + +modInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals + = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules + (ppR, ppRA) = unzip $ map (defInhRule False ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup + in (vlist ppR, concat ppRA) + + +defInhRule new ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals att = + let ppAtt = ppName [pp att, pp (if new then "inh" else "inhM"),prodName] + newAtt = Map.member (identifier att) newAtts + chRMaybe = map (chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals) chids + chR = [ x | (Just x) <- chRMaybe ] + ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName att >|< " nts_" >|< att >|< " $" >-< + indent 4 "do " >-< + indent 5 "loc <- at loc" >-< + indent 5 "lhs <- at lhs" >-< + indent 5 ch >-< + indent 5 "return $" >-< + indent 6 (foldr (>-<) (pp "emptyRecord") chR) + in + if new + then if (newNT || (not newNT && newProd) || newAtt) + then (ppR "inhdefM", [ ppAtt ]) + else (empty, []) + else if (not . null) chR + then (ppR "inhmodM", [ ppAtt ]) + else (empty, []) + + +chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals (idCh,tp) = + let chName = ppName [pp "ch", pp idCh, prodName] + ppTp = ppShow tp + chRule = inhRuleDef new (== idCh) (== att) rules inhNoGroup synNoGroup chids locals -- it's supposed to be only one + in if (isNonterminal tp && (not . null) chRule) + then Just $ chName >|< ".=. (" >|< chRule >|< ") .*. " + else Nothing + + +mapLRuleDefs rules inhNoGroup synNoGroup chids locals + = map appSnd $ sortBy cmpField $ filter ((== "loc") . show . ruleField) rules + where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) + appSnd rule = (ruleDef rule) chids locals + + +mapGRuleDefs filt rules inhNoGroup synNoGroup chids locals + = map appSnd $ sortBy cmpField $ filter (not . (flip elem inhNoGroup) . getName . ruleAttr) + $ filter (not . (flip elem synNoGroup) . getName . ruleAttr) + $ filter ( filt . ruleField) rules + where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) + appSnd rule = (ruleDef rule) chids locals + +inhRuleDef new filt1 filt2 rules inhNoGroup synNoGroup chids locals + = map appSnd $ sortBy cmpField $ filter ( (== not new) . ruleOwrt) + $ filter ((flip elem inhNoGroup) . getName . ruleAttr) + $ filter ( filt2 . getName . ruleAttr) + $ filter ( filt1 . ruleField) rules + where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) + appSnd rule = (ruleDef rule) chids locals + +defRule ppNt (field,att) noGroup rhs = \chids locals -> + let ppAtt = if (elem (getName att) noGroup) + then empty + else case (show field) of + "lhs" -> att >|< "_" >|< pp "SynG" >|< pp "_" >|< ppNt >|< " = " + "loc" -> empty + "inst" -> empty + otherwise -> att >|< "_" >|< pp "InhG" >|< pp "_" >|< + (maybe (error $ "lhs field " ++ show field ++" is not a child") + ppShow (lookup field chids)) + >|< " = " + in ppAtt >|< (rhs noGroup field chids locals) + + +rhsRule ppNt ppProd tks noGroup field chids locals = vlist . lines2PP . (map (token2PP ppNt ppProd field chids locals noGroup )) $ tks + + +lines2PP [] = [] +lines2PP xs = map line2PP . shiftLeft . getLines $ xs + + +token2PP ppNt ppProd field chids locals noGroup tk + = case tk of + AGLocal var pos _ -> (pos, if (elem var locals) + then (ppListSep "(" "" "_" [pp var, ppNt, ppProd]) >|< pp " (loc # att_loc)) " + else pp var) + AGField field attr pos _ -> let ppChT = maybe (error $ "rhs field " ++ show field ++ " is not a child") ppShow (lookup field chids) + ppAtt = case (show field) of + "lhs" -> attName "inh" + "loc" -> attName "loc" + otherwise -> attName "syn" + ppSubAtt = case (show field) of + "lhs" -> ppName [pp (getName attr), pp "InhG", ppNt] + "loc" -> ppName [pp (getName attr), ppNt, ppProd] + otherwise -> ppName [pp (getName attr), pp "SynG", ppChT] + in (pos, if ((elem (getName attr) noGroup) && ((show field) /= "loc")) + then pp "(" >|< pp (getName field) >|< " # " >|< attName (getName attr) >|< pp ")" + else pp "(" >|< ppSubAtt >|< " (" >|< pp (getName field) >|< " # " >|< ppAtt >|< ")) ") + HsToken value pos -> (pos, pp value) + CharToken value pos -> (pos, pp (show value)) + StrToken value pos -> (pos, pp (show value)) + Err mesg pos -> (pos, pp $ " ***" ++ mesg ++ "*** ") + +line2PP ts = let f (p,t) r = let ct = column p + in \c -> pp (spaces (ct-c)) >|< t >|< r (length (show t) +ct) + spaces x | x < 0 = "" + | otherwise = replicate x ' ' + in foldr f (pp . const "") ts 1 + +} + +---------------------------------------------------------------------------------------------------------------------------------------------- + + +{ +ppMacro (Macro con children) = "( atts_" >|< show con >|< ", " >|< ppListSep "" "" " <.> " ppChildren >|<")" + where ppChildren = map ppChild children + ppChild (RuleChild ch n) = chName ch >|< " ==> " >|< ppMacro n + ppChild (ChildChild ch n) = chName ch >|< " --> " >|< n + ppChild (ValueChild ch n) = chName ch >|< " ~~> " >|< n + chName ch = ppName [pp "ch", pp ch, pp con] +} + +-- catamorphisms + +ATTR Nonterminals Nonterminal Productions Production [ | | ppCata USE {>-<} {empty} : PP_Doc ] + +SEM Nonterminal + | Nonterminal lhs . ppCata = "----" >|< @loc.ppNt >-< @prods.ppCata + + +SEM Production + | Production lhs . ppCata = + let extend = maybe [] + ( \ext -> if (@lhs.newNT || (not @lhs.newNT && @loc.newProd)) + then [] + else [ ext >|< ".atts_" >|< @loc.prodName ]) + @lhs.ext + macro = case @macro of + Nothing -> [] + Just macro -> [ "agMacro " >|< ppMacro macro ] + atts = sortBy (\a b -> compare (show a) (show b)) @loc.ppRA + in "atts_" >|< @loc.prodName >|< " = " >|< + ppListSep "" "" " `ext` " + (atts ++ macro ++ extend ) >-< + "semP_" >|< @loc.prodName >|< pp " = knit atts_" >|< @loc.prodName + +{ +ppNoGroupAtts syn noGroup = let synatts = Map.keys $ Map.filterWithKey (\att _ -> elem (getName att) noGroup) syn + in map (flip (>|<) "_inh") noGroup ++ map (flip (>|<) "_syn") synatts + +ruleName att prodName = ppName [att,prodName] + +elemNT a b = False +} + +ATTR Productions Production [ syn, inh : { Attributes } | | ] + +SEM Nonterminal + | Nonterminal prods . syn = @syn + prods . inh = @inh + + + +-- semantic functions + +ATTR Nonterminals Nonterminal Productions Production [ | | ppSF USE {>-<} {empty} : PP_Doc ] +ATTR Productions Production [ | | ppSPF USE {>-<} {empty} : PP_Doc ] + + +SEM Nonterminal + | Nonterminal lhs . ppSF = + let inhAtts = attTypes @loc.inhNoGroup + synAtts = attTypes @loc.synNoGroup + in + "----" >|< @loc.ppNt >-< + "type T_" >|< @loc.ppNt >|< " = " >|< + "(Record " >|< + inhAtts >|< + "(HCons (LVPair (Proxy Att_inh) InhG_" >|< @loc.ppNt >|< ") HNil))" >|< + replicate (length inhAtts) ")" >|< " -> " >|< + "(Record " >|< + synAtts >|< + "(HCons (LVPair (Proxy Att_syn) SynG_" >|< @loc.ppNt >|< ") HNil))" >|< + replicate (length synAtts) ")" >-< + "-- instance SemType T_" >|< @loc.ppNt >|< " " >|< @loc.ppNt >-< + "-- sem_" >|< @loc.ppNt >|< " :: " >|< @loc.ppNt >|< " -> T_" >|< @loc.ppNt >-< + @prods.ppSPF -- >-< + -- @prods.ppSF + +{ +attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts +} + + +SEM Production + | Production lhs . ppSF = + let chi = @children.ppCSF + ppPattern = case (show @con) of + -- hardcoded list support + "Cons" -> ppParams (ppListSep "" "" " : ") + "Nil" -> pp "[]" + -- general case + otherwise -> @loc.conName >|< " " >|< (ppParams ppSpaced) + + ppParams f = f $ map (((>|<) (pp "_")) . fst) chi + in "sem_" >|< @lhs.ppNt >|< " (" >|< ppPattern >|< ") = sem_" >|< @loc.prodName >|< + " (" >|< map (fst . snd) chi >|< "emptyRecord)" + lhs . ppSPF = + let chi = @children.ppCSF + ppParams f = f $ map (((>|<) (pp "_")) . fst) chi + in "sem_" >|< @lhs.ppNt >|< "_" >|< @con >#< ppParams ppSpaced >|< " = semP_" >|< @loc.prodName >|< + " (" >|< map (snd . snd) chi >|< "emptyRecord)" + + +ATTR Children Child [ | | ppCSF USE {++} {[]} : {[(Identifier,(PP_Doc,PP_Doc))]} ] + + +SEM Child + | Child lhs . ppCSF = + let + semC = if (isNonterminal @tp) + then "sem_" >|< ppShow @tp >|< " _" >|< @name + else "sem_Lit _" >|< @name + in case @kind of + ChildSyntax -> [(@name, ( @loc.chLabel >|< " .=. (" >|< semC >|< ") .*. " + , @loc.chLabel >|< " .=. _" >|< @name >|< " .*. "))] + _ -> [] + + + + +-- wrappers + +--TODO: create the records Inh_nt and Syn_nt to wrap the attributes + +ATTR Nonterminals Nonterminal [ | | ppW USE {>-<} {empty} : PP_Doc ] + +SEM Nonterminal + | Nonterminal lhs . ppW = + ppName [pp "wrap", @loc.ppNt] >|< " sem " >|< attVars @inh >|< " = " >-< + " sem " >|< attFields @inh @loc.inhNoGroup @loc.ppNt + + +{ +attVars atts = map (\(a,_) -> "_" >|< a >|< " ") $ Map.toAscList atts +attFields atts noGroup ppNt = + let ng = map (\(a,_) -> attName (getName a) >|< " .=. _" >|< a >|< " .*. ") $ Map.toAscList noGroup + g = ppCommas $ map (\(a,_) -> ppName [pp a, pp "InhG",ppNt] >|< "= _" >|< a) $ Map.toAscList $ Map.difference atts noGroup + in "(" >|< ng >|< "att_inh .=. " >|< ppName [pp "InhG", ppNt] >|< " { " >|< g >|< " } .*. emptyRecord)" +} diff --git a/src-ag/AbstractSyntax.ag b/src-ag/AbstractSyntax.ag --- a/src-ag/AbstractSyntax.ag +++ b/src-ag/AbstractSyntax.ag @@ -1,76 +1,76 @@ -imports -{ --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import Macro --marcos -import CommonTypes -import ErrorMessages -} - -DATA Grammar | Grammar typeSyns : {TypeSyns} - useMap : {UseMap} - derivings : {Derivings} - wrappers : {Set NontermIdent} - nonts : Nonterminals - pragmas : {PragmaMap} -- pragmas defined at a certain alternative - manualAttrOrderMap : {AttrOrderMap} -- manually enforced dependencies between attributes - paramMap : {ParamMap} - contextMap : {ContextMap} - quantMap : {QuantMap} - uniqueMap : {UniqueMap} - augmentsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} - aroundsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} - mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))} - -TYPE Nonterminals = [Nonterminal] - -TYPE Productions = [Production] - -TYPE Children = [Child] - -TYPE Rules = [Rule] - -TYPE TypeSigs = [TypeSig] - -DATA Nonterminal | Nonterminal nt : {NontermIdent} - params : {[Identifier]} - inh : {Attributes} - syn : {Attributes} - prods : Productions - -DATA Production | Production con : {ConstructorIdent} - params : {[Identifier]} - constraints : {[Type]} - children : Children - rules : Rules - typeSigs : TypeSigs - macro : MaybeMacro --marcos - -DATA Child | Child name : {Identifier} - tp : {Type} - kind : {ChildKind} - -DATA Rule | Rule mbName : {Maybe Identifier} - pattern : Pattern - rhs : Expression - owrt : {Bool} - origin : String -- just for documentation (and maybe errors) - explicit : Bool -- True if this rule defined in the source code - pure : Bool -- True if this rule is pure (does not have side effects) - identity : Bool -- True if this rule is an identity rule - mbError : {Maybe Error} -- scheduling this rule yields the given error, if present - eager : Bool -- for ordered scheduling: use an eager semantics - -DATA TypeSig | TypeSig name : {Identifier} - tp : {Type} - -SET AllAbstractSyntax - = Grammar - Nonterminal Nonterminals - Production Productions - Child Children - Rule Rules - TypeSig TypeSigs +imports +{ +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import Macro --marcos +import CommonTypes +import ErrorMessages +} + +DATA Grammar | Grammar typeSyns : {TypeSyns} + useMap : {UseMap} + derivings : {Derivings} + wrappers : {Set NontermIdent} + nonts : Nonterminals + pragmas : {PragmaMap} -- pragmas defined at a certain alternative + manualAttrOrderMap : {AttrOrderMap} -- manually enforced dependencies between attributes + paramMap : {ParamMap} + contextMap : {ContextMap} + quantMap : {QuantMap} + uniqueMap : {UniqueMap} + augmentsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} + aroundsMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} + mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))} + +TYPE Nonterminals = [Nonterminal] + +TYPE Productions = [Production] + +TYPE Children = [Child] + +TYPE Rules = [Rule] + +TYPE TypeSigs = [TypeSig] + +DATA Nonterminal | Nonterminal nt : {NontermIdent} + params : {[Identifier]} + inh : {Attributes} + syn : {Attributes} + prods : Productions + +DATA Production | Production con : {ConstructorIdent} + params : {[Identifier]} + constraints : {[Type]} + children : Children + rules : Rules + typeSigs : TypeSigs + macro : MaybeMacro --marcos + +DATA Child | Child name : {Identifier} + tp : {Type} + kind : {ChildKind} + +DATA Rule | Rule mbName : {Maybe Identifier} + pattern : Pattern + rhs : Expression + owrt : {Bool} + origin : String -- just for documentation (and maybe errors) + explicit : Bool -- True if this rule defined in the source code + pure : Bool -- True if this rule is pure (does not have side effects) + identity : Bool -- True if this rule is an identity rule + mbError : {Maybe Error} -- scheduling this rule yields the given error, if present + eager : Bool -- for ordered scheduling: use an eager semantics + +DATA TypeSig | TypeSig name : {Identifier} + tp : {Type} + +SET AllAbstractSyntax + = Grammar + Nonterminal Nonterminals + Production Productions + Child Children + Rule Rules + TypeSig TypeSigs diff --git a/src-ag/AbstractSyntaxDump.ag b/src-ag/AbstractSyntaxDump.ag --- a/src-ag/AbstractSyntaxDump.ag +++ b/src-ag/AbstractSyntaxDump.ag @@ -1,76 +1,76 @@ -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" - -imports -{ -import Data.List -import qualified Data.Map as Map - -import Pretty -import PPUtil - -import AbstractSyntax -import TokenDef -} - -ATTR AllPattern AllAbstractSyntax AllExpression [ | | pp USE {>-<} {empty} : PP_Doc ] - -SEM Grammar - | Grammar lhs . pp = ppNestInfo ["Grammar","Grammar"] [] - [ ppF "typeSyns" $ ppAssocL @typeSyns - , ppF "useMap" $ ppMap $ Map.map ppMap $ @useMap - , ppF "derivings" $ ppMap $ @derivings - , ppF "wrappers" $ ppShow $ @wrappers - , ppF "nonts" $ ppVList @nonts.ppL - ] [] - -SEM Nonterminal - | Nonterminal lhs . pp = ppNestInfo ["Nonterminal","Nonterminal"] (pp @nt : map pp @params) [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "prods" $ ppVList @prods.ppL] [] - -SEM Production - | Production lhs . pp = ppNestInfo ["Production","Production"] [pp @con] [ppF "children" $ ppVList @children.ppL,ppF "rules" $ ppVList @rules.ppL,ppF "typeSigs" $ ppVList @typeSigs.ppL] [] - -SEM Child - | Child lhs . pp = ppNestInfo ["Child","Child"] [pp @name, ppShow @tp] [ppF "kind" $ ppShow @kind] [] - -SEM Rule - | Rule lhs . pp = ppNestInfo ["Rule","Rule"] [ppShow @owrt, pp @origin] [ppF "pattern" $ @pattern.pp, ppF "rhs" $ @rhs.pp] [] - -SEM TypeSig - | TypeSig lhs . pp = ppNestInfo ["TypeSig","TypeSig"] [pp @name, ppShow @tp] [] [] - -SEM Pattern - | Constr lhs . pp = ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] [] - | Product lhs . pp = ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] [] - | Alias lhs . pp = ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] [] - | Underscore lhs . pp = ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] [] - -SEM Expression - | Expression lhs . pp = ppNestInfo ["Expression","Expression"] [ppShow @pos] [ppF "txt" $ vlist . showTokens . tokensToStrings $ @tks] [] - -ATTR Productions Nonterminals Children Rules TypeSigs Patterns [ | | ppL: {[PP_Doc]} ] - -SEM Patterns - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM TypeSigs - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM Rules - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM Children - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM Productions - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM Nonterminals - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] +INCLUDE "AbstractSyntax.ag" +INCLUDE "Patterns.ag" +INCLUDE "Expression.ag" + +imports +{ +import Data.List +import qualified Data.Map as Map + +import Pretty +import PPUtil + +import AbstractSyntax +import TokenDef +} + +ATTR AllPattern AllAbstractSyntax AllExpression [ | | pp USE {>-<} {empty} : PP_Doc ] + +SEM Grammar + | Grammar lhs . pp = ppNestInfo ["Grammar","Grammar"] [] + [ ppF "typeSyns" $ ppAssocL @typeSyns + , ppF "useMap" $ ppMap $ Map.map ppMap $ @useMap + , ppF "derivings" $ ppMap $ @derivings + , ppF "wrappers" $ ppShow $ @wrappers + , ppF "nonts" $ ppVList @nonts.ppL + ] [] + +SEM Nonterminal + | Nonterminal lhs . pp = ppNestInfo ["Nonterminal","Nonterminal"] (pp @nt : map pp @params) [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "prods" $ ppVList @prods.ppL] [] + +SEM Production + | Production lhs . pp = ppNestInfo ["Production","Production"] [pp @con] [ppF "children" $ ppVList @children.ppL,ppF "rules" $ ppVList @rules.ppL,ppF "typeSigs" $ ppVList @typeSigs.ppL] [] + +SEM Child + | Child lhs . pp = ppNestInfo ["Child","Child"] [pp @name, ppShow @tp] [ppF "kind" $ ppShow @kind] [] + +SEM Rule + | Rule lhs . pp = ppNestInfo ["Rule","Rule"] [ppShow @owrt, pp @origin] [ppF "pattern" $ @pattern.pp, ppF "rhs" $ @rhs.pp] [] + +SEM TypeSig + | TypeSig lhs . pp = ppNestInfo ["TypeSig","TypeSig"] [pp @name, ppShow @tp] [] [] + +SEM Pattern + | Constr lhs . pp = ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] [] + | Product lhs . pp = ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] [] + | Alias lhs . pp = ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] [] + | Underscore lhs . pp = ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] [] + +SEM Expression + | Expression lhs . pp = ppNestInfo ["Expression","Expression"] [ppShow @pos] [ppF "txt" $ vlist . showTokens . tokensToStrings $ @tks] [] + +ATTR Productions Nonterminals Children Rules TypeSigs Patterns [ | | ppL: {[PP_Doc]} ] + +SEM Patterns + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] + +SEM TypeSigs + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] + +SEM Rules + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] + +SEM Children + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] + +SEM Productions + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] + +SEM Nonterminals + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] diff --git a/src-ag/Code.ag b/src-ag/Code.ag --- a/src-ag/Code.ag +++ b/src-ag/Code.ag @@ -1,163 +1,163 @@ -imports -{ -import Patterns -import Data.Set(Set) -import qualified Data.Set as Set -import Data.Map(Map) -import qualified Data.Map as Map -} - -TYPE Exprs = [Expr] -TYPE Decls = [Decl] -TYPE Chunks = [Chunk] -TYPE DataAlts = [DataAlt] -TYPE CaseAlts = [CaseAlt] -TYPE Types = [Type] -TYPE NamedTypes = [NamedType] - -DATA Program | Program chunks : Chunks - ordered : Bool - -DATA Chunk | Chunk name : String - comment : Decl - info : Decls - dataDef : Decls - cataFun : Decls - semDom : Decls - semWrapper : Decls - semFunctions : Decls - semNames : {[String]} - -DATA Expr | Let decls : Decls - body : Expr - | Case expr : Expr - alts : CaseAlts - | Do stmts : Decls - body : Expr - | Lambda args : Exprs - body : Expr - | TupleExpr exprs : Exprs - | UnboxedTupleExpr exprs : Exprs - | App name : {String} - args : Exprs - | SimpleExpr txt : {String} - | TextExpr lns : {[String]} - | Trace txt : {String} - expr : Expr - | PragmaExpr onLeftSide : {Bool} - onNewLine : {Bool} - txt : {String} - expr : Expr - | LineExpr expr : Expr - | TypedExpr expr : Expr - tp : Type - | ResultExpr nt : String - expr : Expr - | InvokeExpr nt : String - expr : Expr - args : Exprs - | ResumeExpr nt : String - expr : Expr - left : Lhs - rhs : Expr - | SemFun nt : {String} - args : Exprs - body : Expr - -DATA CaseAlt | CaseAlt left : Lhs - expr : Expr - -DATA Decl | Decl left : Lhs - rhs : Expr - binds : {Set String} -- set of variable names bound by the left-hand side - uses : {Set String} -- set of variable names used by the right-hand side - | Bind left : Lhs - rhs : Expr - | BindLet left : Lhs - rhs : Expr - | Data name : {String} - params: {[String]} - alts : DataAlts - strict: Bool - derivings : {[String]} - | NewType name : {String} - params: {[String]} - con : {String} - tp : Type - | Type name : {String} - params: {[String]} - tp : Type - | TSig name : {String} - tp : Type - | Comment txt : {String} - | PragmaDecl txt : {String} - - | Resume monadic : {Bool} - nt : String - left : Lhs - rhs : Expr - | EvalDecl nt : String - left : Lhs - rhs : Expr - -DATA DataAlt | DataAlt name : {String} - args : Types - | Record name : {String} - args : NamedTypes - -DATA NamedType | Named strict: {Bool} - name : {String} - tp : Type - -DATA Type | Arr left : Type - right : Type - | CtxApp left : {[(String, [String])]} - right : Type - | QuantApp left : String - right : Type - | TypeApp func : Type - args : Types - | TupleType tps : Types - | UnboxedTupleType tps : Types - | List tp : Type - | SimpleType txt : {String} - | NontermType name : String - params : {[String]} - deforested : Bool - | TMaybe tp : Type - | TEither left : Type - right : Type - | TMap key : Type - value : Type - | TIntMap value : Type - | TSet tp : Type - | TIntSet - -DATA Lhs | Pattern3 pat3 : Pattern - | Pattern3SM pat3 : Pattern - | TupleLhs comps : {[String]} -- \ [Lhs] appears to be more sensible - | UnboxedTupleLhs comps : {[String]} -- / - | Fun name : {String} - args : Exprs - | Unwrap name : {String} sub : Lhs - -DERIVING Type : Show - -{ --- Unboxed tuples --- unbox Whether unboxed tuples are wanted or not --- inh The inherited attributes. --- If there are none, no unboxing can take place, --- because in that case the semantic function (a top-level identifier) would have an unboxed type. --- Of course we can't have an unboxed 1-tuple -mkTupleExpr :: Bool -> Bool -> Exprs -> Expr -mkTupleExpr unbox' noInh exprs | not unbox' || noInh || length exprs == 1 = TupleExpr exprs - | otherwise = UnboxedTupleExpr exprs -mkTupleType :: Bool -> Bool -> Types -> Type -mkTupleType unbox' noInh tps | not unbox' || noInh || length tps == 1 = TupleType tps - | otherwise = UnboxedTupleType tps -mkTupleLhs :: Bool -> Bool -> [String] -> Lhs -mkTupleLhs unbox' noInh comps | not unbox' || noInh || length comps == 1 = TupleLhs comps - | otherwise = UnboxedTupleLhs comps -} - +imports +{ +import Patterns +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Map(Map) +import qualified Data.Map as Map +} + +TYPE Exprs = [Expr] +TYPE Decls = [Decl] +TYPE Chunks = [Chunk] +TYPE DataAlts = [DataAlt] +TYPE CaseAlts = [CaseAlt] +TYPE Types = [Type] +TYPE NamedTypes = [NamedType] + +DATA Program | Program chunks : Chunks + ordered : Bool + +DATA Chunk | Chunk name : String + comment : Decl + info : Decls + dataDef : Decls + cataFun : Decls + semDom : Decls + semWrapper : Decls + semFunctions : Decls + semNames : {[String]} + +DATA Expr | Let decls : Decls + body : Expr + | Case expr : Expr + alts : CaseAlts + | Do stmts : Decls + body : Expr + | Lambda args : Exprs + body : Expr + | TupleExpr exprs : Exprs + | UnboxedTupleExpr exprs : Exprs + | App name : {String} + args : Exprs + | SimpleExpr txt : {String} + | TextExpr lns : {[String]} + | Trace txt : {String} + expr : Expr + | PragmaExpr onLeftSide : {Bool} + onNewLine : {Bool} + txt : {String} + expr : Expr + | LineExpr expr : Expr + | TypedExpr expr : Expr + tp : Type + | ResultExpr nt : String + expr : Expr + | InvokeExpr nt : String + expr : Expr + args : Exprs + | ResumeExpr nt : String + expr : Expr + left : Lhs + rhs : Expr + | SemFun nt : {String} + args : Exprs + body : Expr + +DATA CaseAlt | CaseAlt left : Lhs + expr : Expr + +DATA Decl | Decl left : Lhs + rhs : Expr + binds : {Set String} -- set of variable names bound by the left-hand side + uses : {Set String} -- set of variable names used by the right-hand side + | Bind left : Lhs + rhs : Expr + | BindLet left : Lhs + rhs : Expr + | Data name : {String} + params: {[String]} + alts : DataAlts + strict: Bool + derivings : {[String]} + | NewType name : {String} + params: {[String]} + con : {String} + tp : Type + | Type name : {String} + params: {[String]} + tp : Type + | TSig name : {String} + tp : Type + | Comment txt : {String} + | PragmaDecl txt : {String} + + | Resume monadic : {Bool} + nt : String + left : Lhs + rhs : Expr + | EvalDecl nt : String + left : Lhs + rhs : Expr + +DATA DataAlt | DataAlt name : {String} + args : Types + | Record name : {String} + args : NamedTypes + +DATA NamedType | Named strict: {Bool} + name : {String} + tp : Type + +DATA Type | Arr left : Type + right : Type + | CtxApp left : {[(String, [String])]} + right : Type + | QuantApp left : String + right : Type + | TypeApp func : Type + args : Types + | TupleType tps : Types + | UnboxedTupleType tps : Types + | List tp : Type + | SimpleType txt : {String} + | NontermType name : String + params : {[String]} + deforested : Bool + | TMaybe tp : Type + | TEither left : Type + right : Type + | TMap key : Type + value : Type + | TIntMap value : Type + | TSet tp : Type + | TIntSet + +DATA Lhs | Pattern3 pat3 : Pattern + | Pattern3SM pat3 : Pattern + | TupleLhs comps : {[String]} -- \ [Lhs] appears to be more sensible + | UnboxedTupleLhs comps : {[String]} -- / + | Fun name : {String} + args : Exprs + | Unwrap name : {String} sub : Lhs + +DERIVING Type : Show + +{ +-- Unboxed tuples +-- unbox Whether unboxed tuples are wanted or not +-- inh The inherited attributes. +-- If there are none, no unboxing can take place, +-- because in that case the semantic function (a top-level identifier) would have an unboxed type. +-- Of course we can't have an unboxed 1-tuple +mkTupleExpr :: Bool -> Bool -> Exprs -> Expr +mkTupleExpr unbox' noInh exprs | not unbox' || noInh || length exprs == 1 = TupleExpr exprs + | otherwise = UnboxedTupleExpr exprs +mkTupleType :: Bool -> Bool -> Types -> Type +mkTupleType unbox' noInh tps | not unbox' || noInh || length tps == 1 = TupleType tps + | otherwise = UnboxedTupleType tps +mkTupleLhs :: Bool -> Bool -> [String] -> Lhs +mkTupleLhs unbox' noInh comps | not unbox' || noInh || length comps == 1 = TupleLhs comps + | otherwise = UnboxedTupleLhs comps +} + diff --git a/src-ag/CodeSyntax.ag b/src-ag/CodeSyntax.ag --- a/src-ag/CodeSyntax.ag +++ b/src-ag/CodeSyntax.ag @@ -1,90 +1,90 @@ -imports -{ -import Patterns -import CommonTypes -import Data.Map(Map) -import Data.Set(Set) -} - -DATA CGrammar - | CGrammar typeSyns : {TypeSyns} - derivings : {Derivings} - wrappers : {Set NontermIdent} - nonts : CNonterminals - pragmas : {PragmaMap} - paramMap : {ParamMap} - contextMap: {ContextMap} - quantMap : {QuantMap} - aroundsMap: {Map NontermIdent (Map ConstructorIdent (Set Identifier))} - mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} - multivisit : {Bool} - -TYPE CNonterminals = [CNonterminal] - -DATA CNonterminal - | CNonterminal nt : NontermIdent - params : {[Identifier]} - inh : Attributes - syn : Attributes - prods : CProductions - inter : CInterface - -DATA CInterface - | CInterface seg:CSegments - -TYPE CSegments = [CSegment] - -DATA CSegment - | CSegment inh : Attributes - syn : Attributes - -TYPE CProductions = [CProduction] - -DATA CProduction - | CProduction con : ConstructorIdent - visits : CVisits - children : {[(Identifier,Type,ChildKind)]} - terminals : {[Identifier]} - -TYPE CVisits = [CVisit] - -DATA CVisit - | CVisit inh : Attributes - syn : Attributes - vss : Sequence -- sequence of "steps", where each "step" is either an attribute definition or a child visit - intra : Sequence -- how to glue the visits together (child visits are child-intra's, attr-defs are attr-intra's) - ordered : Bool -- indicates that vss is ordered - -TYPE Sequence = [CRule] - -DATA CRule - | CRule name : Identifier - isIn : Bool -- True iff there is a definition for an inherited attribute - hasCode : Bool -- True iff there is an RHS - nt : NontermIdent - con : ConstructorIdent - field : Identifier - childnt : {Maybe NontermIdent} -- Just n: 'field' of 'nt' and 'con' is a nonterminal 'n', Nothing: it is a terminal - tp : {Maybe Type} -- type of the attribute - pattern : Pattern -- only defined if 'isIn' is False - rhs : {[String]} -- empty string if 'hasCode' is False - defines : {Map Int (Identifier,Identifier,Maybe Type)} -- the attributes defined by this rule - owrt : {Bool} - origin : String -- just for documentation (and maybe errors) - uses : {Set (Identifier, Identifier)} - explicit : Bool -- True if this an explicit rule found in the source file - mbNamed : {Maybe Identifier} - | CChildVisit name : Identifier -- corresponding to the name of the child - nt : NontermIdent - nr : Int -- visit number - inh : Attributes - syn : Attributes - isLast : Bool -- indicates whether this is the last visit to this child - -SET AllCodeSyntax - = CGrammar - CNonterminal CNonterminals - CInterface CSegments CSegment - CProduction CProductions - CVisits CVisit - CRule +imports +{ +import Patterns +import CommonTypes +import Data.Map(Map) +import Data.Set(Set) +} + +DATA CGrammar + | CGrammar typeSyns : {TypeSyns} + derivings : {Derivings} + wrappers : {Set NontermIdent} + nonts : CNonterminals + pragmas : {PragmaMap} + paramMap : {ParamMap} + contextMap: {ContextMap} + quantMap : {QuantMap} + aroundsMap: {Map NontermIdent (Map ConstructorIdent (Set Identifier))} + mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} + multivisit : {Bool} + +TYPE CNonterminals = [CNonterminal] + +DATA CNonterminal + | CNonterminal nt : NontermIdent + params : {[Identifier]} + inh : Attributes + syn : Attributes + prods : CProductions + inter : CInterface + +DATA CInterface + | CInterface seg:CSegments + +TYPE CSegments = [CSegment] + +DATA CSegment + | CSegment inh : Attributes + syn : Attributes + +TYPE CProductions = [CProduction] + +DATA CProduction + | CProduction con : ConstructorIdent + visits : CVisits + children : {[(Identifier,Type,ChildKind)]} + terminals : {[Identifier]} + +TYPE CVisits = [CVisit] + +DATA CVisit + | CVisit inh : Attributes + syn : Attributes + vss : Sequence -- sequence of "steps", where each "step" is either an attribute definition or a child visit + intra : Sequence -- how to glue the visits together (child visits are child-intra's, attr-defs are attr-intra's) + ordered : Bool -- indicates that vss is ordered + +TYPE Sequence = [CRule] + +DATA CRule + | CRule name : Identifier + isIn : Bool -- True iff there is a definition for an inherited attribute + hasCode : Bool -- True iff there is an RHS + nt : NontermIdent + con : ConstructorIdent + field : Identifier + childnt : {Maybe NontermIdent} -- Just n: 'field' of 'nt' and 'con' is a nonterminal 'n', Nothing: it is a terminal + tp : {Maybe Type} -- type of the attribute + pattern : Pattern -- only defined if 'isIn' is False + rhs : {[String]} -- empty string if 'hasCode' is False + defines : {Map Int (Identifier,Identifier,Maybe Type)} -- the attributes defined by this rule + owrt : {Bool} + origin : String -- just for documentation (and maybe errors) + uses : {Set (Identifier, Identifier)} + explicit : Bool -- True if this an explicit rule found in the source file + mbNamed : {Maybe Identifier} + | CChildVisit name : Identifier -- corresponding to the name of the child + nt : NontermIdent + nr : Int -- visit number + inh : Attributes + syn : Attributes + isLast : Bool -- indicates whether this is the last visit to this child + +SET AllCodeSyntax + = CGrammar + CNonterminal CNonterminals + CInterface CSegments CSegment + CProduction CProductions + CVisits CVisit + CRule diff --git a/src-ag/CodeSyntaxDump.ag b/src-ag/CodeSyntaxDump.ag --- a/src-ag/CodeSyntaxDump.ag +++ b/src-ag/CodeSyntaxDump.ag @@ -1,103 +1,103 @@ -INCLUDE "CodeSyntax.ag" -INCLUDE "Patterns.ag" - -imports -{ -import Data.List -import qualified Data.Map as Map - -import Pretty -import PPUtil - -import CodeSyntax -} - -{ -ppChild :: (Identifier,Type,ChildKind) -> PP_Doc -ppChild (nm,tp,_) - = pp nm >#< "::" >#< pp (show tp) - -ppVertexMap :: Map Int (Identifier,Identifier,Maybe Type) -> PP_Doc -ppVertexMap m - = ppVList [ ppF (show k) $ ppAttr v | (k,v) <- Map.toList m ] - -ppAttr :: (Identifier,Identifier,Maybe Type) -> PP_Doc -ppAttr (fld,nm,mTp) - = pp fld >|< "." >|< pp nm >#< - case mTp of - Just tp -> pp "::" >#< show tp - Nothing -> empty - -ppBool :: Bool -> PP_Doc -ppBool True = pp "T" -ppBool False = pp "F" - -ppMaybeShow :: Show a => Maybe a -> PP_Doc -ppMaybeShow (Just x) = pp (show x) -ppMaybeShow Nothing = pp "_" - -ppStrings :: [String] -> PP_Doc -ppStrings = vlist -} - - -ATTR AllPattern AllCodeSyntax [ | | pp USE {>-<} {empty} : PP_Doc ] - -SEM CGrammar - | CGrammar lhs . pp = ppNestInfo ["CGrammar","CGrammar"] [] - [ ppF "typeSyns" $ ppAssocL @typeSyns - , ppF "derivings" $ ppMap $ @derivings - , ppF "nonts" $ ppVList @nonts.ppL - ] [] - -SEM CNonterminal - | CNonterminal lhs . pp = ppNestInfo ["CNonterminal","CNonterminal"] (pp @nt : map pp @params) [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "prods" $ ppVList @prods.ppL, ppF "inter" @inter.pp] [] - -SEM CInterface - | CInterface lhs . pp = ppNestInfo ["CInterface","CInterface"] [] [ppF "seg" $ ppVList @seg.ppL] [] - -SEM CSegment - | CSegment lhs . pp = ppNestInfo ["CSegment","CSegment"] [] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn] [] - -SEM CProduction - | CProduction lhs . pp = ppNestInfo ["CProduction","CProduction"] [pp @con] [ppF "visits" $ ppVList @visits.ppL, ppF "children" $ ppVList (map ppChild @children),ppF "terminals" $ ppVList (map ppShow @terminals)] [] - -SEM CVisit - | CVisit lhs . pp = ppNestInfo ["CVisit","CVisit"] [] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "sequence" $ ppVList @vss.ppL, ppF "intra" $ ppVList @intra.ppL, ppF "ordered" $ ppBool @ordered] [] - -SEM CRule - | CRule lhs . pp = ppNestInfo ["CRule","CRule"] [pp @name] [ppF "isIn" $ ppBool @isIn, ppF "hasCode" $ ppBool @hasCode, ppF "nt" $ pp @nt, ppF "con" $ pp @con, ppF "field" $ pp @field, ppF "childnt" $ ppMaybeShow @childnt, ppF "tp" $ ppMaybeShow @tp, ppF "pattern" $ if @isIn then pp "" else @pattern.pp, ppF "rhs" $ ppStrings @rhs, ppF "defines" $ ppVertexMap @defines, ppF "owrt" $ ppBool @owrt, ppF "origin" $ pp @origin] [] - | CChildVisit lhs . pp = ppNestInfo ["CRule","CChildVisit"] [pp @name] [ppF "nt" $ pp @nt, ppF "nr" $ ppShow @nr, ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "last" $ ppBool @isLast] [] - -SEM Pattern - | Constr lhs . pp = ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] [] - | Product lhs . pp = ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] [] - | Alias lhs . pp = ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] [] - | Underscore lhs . pp = ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] [] - - -ATTR CNonterminals CSegments CProductions CVisits Sequence Patterns [ | | ppL: {[PP_Doc]} ] - -SEM Patterns - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM Sequence - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM CVisits - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM CProductions - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM CSegments - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] - -SEM CNonterminals - | Cons lhs . ppL = @hd.pp : @tl.ppL - | Nil lhs . ppL = [] +INCLUDE "CodeSyntax.ag" +INCLUDE "Patterns.ag" + +imports +{ +import Data.List +import qualified Data.Map as Map + +import Pretty +import PPUtil + +import CodeSyntax +} + +{ +ppChild :: (Identifier,Type,ChildKind) -> PP_Doc +ppChild (nm,tp,_) + = pp nm >#< "::" >#< pp (show tp) + +ppVertexMap :: Map Int (Identifier,Identifier,Maybe Type) -> PP_Doc +ppVertexMap m + = ppVList [ ppF (show k) $ ppAttr v | (k,v) <- Map.toList m ] + +ppAttr :: (Identifier,Identifier,Maybe Type) -> PP_Doc +ppAttr (fld,nm,mTp) + = pp fld >|< "." >|< pp nm >#< + case mTp of + Just tp -> pp "::" >#< show tp + Nothing -> empty + +ppBool :: Bool -> PP_Doc +ppBool True = pp "T" +ppBool False = pp "F" + +ppMaybeShow :: Show a => Maybe a -> PP_Doc +ppMaybeShow (Just x) = pp (show x) +ppMaybeShow Nothing = pp "_" + +ppStrings :: [String] -> PP_Doc +ppStrings = vlist +} + + +ATTR AllPattern AllCodeSyntax [ | | pp USE {>-<} {empty} : PP_Doc ] + +SEM CGrammar + | CGrammar lhs . pp = ppNestInfo ["CGrammar","CGrammar"] [] + [ ppF "typeSyns" $ ppAssocL @typeSyns + , ppF "derivings" $ ppMap $ @derivings + , ppF "nonts" $ ppVList @nonts.ppL + ] [] + +SEM CNonterminal + | CNonterminal lhs . pp = ppNestInfo ["CNonterminal","CNonterminal"] (pp @nt : map pp @params) [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "prods" $ ppVList @prods.ppL, ppF "inter" @inter.pp] [] + +SEM CInterface + | CInterface lhs . pp = ppNestInfo ["CInterface","CInterface"] [] [ppF "seg" $ ppVList @seg.ppL] [] + +SEM CSegment + | CSegment lhs . pp = ppNestInfo ["CSegment","CSegment"] [] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn] [] + +SEM CProduction + | CProduction lhs . pp = ppNestInfo ["CProduction","CProduction"] [pp @con] [ppF "visits" $ ppVList @visits.ppL, ppF "children" $ ppVList (map ppChild @children),ppF "terminals" $ ppVList (map ppShow @terminals)] [] + +SEM CVisit + | CVisit lhs . pp = ppNestInfo ["CVisit","CVisit"] [] [ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "sequence" $ ppVList @vss.ppL, ppF "intra" $ ppVList @intra.ppL, ppF "ordered" $ ppBool @ordered] [] + +SEM CRule + | CRule lhs . pp = ppNestInfo ["CRule","CRule"] [pp @name] [ppF "isIn" $ ppBool @isIn, ppF "hasCode" $ ppBool @hasCode, ppF "nt" $ pp @nt, ppF "con" $ pp @con, ppF "field" $ pp @field, ppF "childnt" $ ppMaybeShow @childnt, ppF "tp" $ ppMaybeShow @tp, ppF "pattern" $ if @isIn then pp "" else @pattern.pp, ppF "rhs" $ ppStrings @rhs, ppF "defines" $ ppVertexMap @defines, ppF "owrt" $ ppBool @owrt, ppF "origin" $ pp @origin] [] + | CChildVisit lhs . pp = ppNestInfo ["CRule","CChildVisit"] [pp @name] [ppF "nt" $ pp @nt, ppF "nr" $ ppShow @nr, ppF "inh" $ ppMap @inh, ppF "syn" $ ppMap @syn, ppF "last" $ ppBool @isLast] [] + +SEM Pattern + | Constr lhs . pp = ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] [] + | Product lhs . pp = ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] [] + | Alias lhs . pp = ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] [] + | Underscore lhs . pp = ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] [] + + +ATTR CNonterminals CSegments CProductions CVisits Sequence Patterns [ | | ppL: {[PP_Doc]} ] + +SEM Patterns + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] + +SEM Sequence + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] + +SEM CVisits + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] + +SEM CProductions + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] + +SEM CSegments + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] + +SEM CNonterminals + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] diff --git a/src-ag/ConcreteSyntax.ag b/src-ag/ConcreteSyntax.ag --- a/src-ag/ConcreteSyntax.ag +++ b/src-ag/ConcreteSyntax.ag @@ -1,132 +1,132 @@ -imports -{ -import UU.Scanner.Position (Pos) -import Patterns (Pattern) -import Expression (Expression) -import CommonTypes -import Macro --marcos -} - - -TYPE Elems = [Elem] - -TYPE Alts = [Alt] - -TYPE Fields = [Field] - -TYPE SemAlts = [SemAlt] - -TYPE SemDefs = [SemDef] - -DATA AG | AG elems : Elems - -DATA Elem | Data pos : {Pos} - contype : {ConstructorType} - ctx : {ClassContext} - names : NontSet - params : {[Identifier]} - attrs : Attrs - alts : Alts - ext : {Bool} - - | Type pos : {Pos} - ctx : {ClassContext} - name : {NontermIdent} - params : {[Identifier]} - type : {ComplexType} - - | Attr pos : {Pos} - ctx : {ClassContext} - names : NontSet - quants : {[String]} - attrs : Attrs - - | Sem pos : {Pos} - ctx : {ClassContext} - names : NontSet - attrs : Attrs - quants : {[String]} - alts : SemAlts - - | Txt pos : {Pos} - kind : {BlockKind} - mbNt : {Maybe NontermIdent} - lines : {[String]} - - | Set pos : {Pos} - name : {NontermIdent} - merge : Bool - set : NontSet - - | Deriving pos : {Pos} - set : NontSet - classes : {[NontermIdent]} - - | Wrapper pos : {Pos} - set : NontSet - - | Nocatas pos : {Pos} - set : NontSet - - | Pragma pos : {Pos} - names: {[NontermIdent]} - - | Module pos : {Pos} - name : {String} -- name of the haskell module - exports : {String} -- exports of the haskell module - imports : {String} -- imports to replicate to generated haskell modules - -DATA Attrs | Attrs pos : {Pos} - inh,chn,syn : {AttrNames} - -DATA Alt | Alt pos : {Pos} - names : ConstructorSet - tyvars : {[Identifier]} - fields : Fields - macro : MaybeMacro --marcos: macro extension - -DATA Field | FChild name : Identifier - tp : Type - | FCtx tps : {[Type]} - -DATA SemAlt | SemAlt pos : {Pos} - constructorSet : ConstructorSet - rules : SemDefs - -DATA SemDef | Def pos : Pos - mbName : {Maybe Identifier} - pattern: Pattern - rhs : {Expression} - owrt : {Bool} - pure : Bool - eager : Bool - | TypeDef pos : {Pos} - ident : {Identifier} - tp : Type - | UniqueDef ident : {Identifier} - ref : {Identifier} - | AugmentDef ident : {Identifier} - rhs : {Expression} - | AroundDef ident : {Identifier} - rhs : {Expression} - | MergeDef target : {Identifier} - nt : {Identifier} - sources : {[Identifier]} - rhs : {Expression} - | SemPragma names : {[NontermIdent]} - | AttrOrderBefore before : {[Occurrence]} - after : {[Occurrence]} - -DATA ConstructorSet | CName name : {ConstructorIdent} - | CUnion set1,set2 : ConstructorSet - | CDifference set1,set2 : ConstructorSet - | CAll - -DATA NontSet | NamedSet name : {NontermIdent} - | All - | Union set1,set2 : NontSet - | Intersect set1,set2 : NontSet - | Difference set1,set2 : NontSet - | Path from,to : {NontermIdent} - - +imports +{ +import UU.Scanner.Position (Pos) +import Patterns (Pattern) +import Expression (Expression) +import CommonTypes +import Macro --marcos +} + + +TYPE Elems = [Elem] + +TYPE Alts = [Alt] + +TYPE Fields = [Field] + +TYPE SemAlts = [SemAlt] + +TYPE SemDefs = [SemDef] + +DATA AG | AG elems : Elems + +DATA Elem | Data pos : {Pos} + contype : {ConstructorType} + ctx : {ClassContext} + names : NontSet + params : {[Identifier]} + attrs : Attrs + alts : Alts + ext : {Bool} + + | Type pos : {Pos} + ctx : {ClassContext} + name : {NontermIdent} + params : {[Identifier]} + type : {ComplexType} + + | Attr pos : {Pos} + ctx : {ClassContext} + names : NontSet + quants : {[String]} + attrs : Attrs + + | Sem pos : {Pos} + ctx : {ClassContext} + names : NontSet + attrs : Attrs + quants : {[String]} + alts : SemAlts + + | Txt pos : {Pos} + kind : {BlockKind} + mbNt : {Maybe NontermIdent} + lines : {[String]} + + | Set pos : {Pos} + name : {NontermIdent} + merge : Bool + set : NontSet + + | Deriving pos : {Pos} + set : NontSet + classes : {[NontermIdent]} + + | Wrapper pos : {Pos} + set : NontSet + + | Nocatas pos : {Pos} + set : NontSet + + | Pragma pos : {Pos} + names: {[NontermIdent]} + + | Module pos : {Pos} + name : {String} -- name of the haskell module + exports : {String} -- exports of the haskell module + imports : {String} -- imports to replicate to generated haskell modules + +DATA Attrs | Attrs pos : {Pos} + inh,chn,syn : {AttrNames} + +DATA Alt | Alt pos : {Pos} + names : ConstructorSet + tyvars : {[Identifier]} + fields : Fields + macro : MaybeMacro --marcos: macro extension + +DATA Field | FChild name : Identifier + tp : Type + | FCtx tps : {[Type]} + +DATA SemAlt | SemAlt pos : {Pos} + constructorSet : ConstructorSet + rules : SemDefs + +DATA SemDef | Def pos : Pos + mbName : {Maybe Identifier} + pattern: Pattern + rhs : {Expression} + owrt : {Bool} + pure : Bool + eager : Bool + | TypeDef pos : {Pos} + ident : {Identifier} + tp : Type + | UniqueDef ident : {Identifier} + ref : {Identifier} + | AugmentDef ident : {Identifier} + rhs : {Expression} + | AroundDef ident : {Identifier} + rhs : {Expression} + | MergeDef target : {Identifier} + nt : {Identifier} + sources : {[Identifier]} + rhs : {Expression} + | SemPragma names : {[NontermIdent]} + | AttrOrderBefore before : {[Occurrence]} + after : {[Occurrence]} + +DATA ConstructorSet | CName name : {ConstructorIdent} + | CUnion set1,set2 : ConstructorSet + | CDifference set1,set2 : ConstructorSet + | CAll + +DATA NontSet | NamedSet name : {NontermIdent} + | All + | Union set1,set2 : NontSet + | Intersect set1,set2 : NontSet + | Difference set1,set2 : NontSet + | Path from,to : {NontermIdent} + + diff --git a/src-ag/DeclBlocks.ag b/src-ag/DeclBlocks.ag --- a/src-ag/DeclBlocks.ag +++ b/src-ag/DeclBlocks.ag @@ -1,20 +1,20 @@ -imports -{ -import Code (Decl,Expr) -} - - -DATA DeclBlocksRoot - | DeclBlocksRoot - blocks : DeclBlocks - - -DATA DeclBlocks - | DeclBlock - defs : {[Decl]} - visit : {Decl} - next : DeclBlocks - | DeclTerminator - defs : {[Decl]} - result : {Expr} - +imports +{ +import Code (Decl,Expr) +} + + +DATA DeclBlocksRoot + | DeclBlocksRoot + blocks : DeclBlocks + + +DATA DeclBlocks + | DeclBlock + defs : {[Decl]} + visit : {Decl} + next : DeclBlocks + | DeclTerminator + defs : {[Decl]} + result : {Expr} + diff --git a/src-ag/DefaultRules.ag b/src-ag/DefaultRules.ag --- a/src-ag/DefaultRules.ag +++ b/src-ag/DefaultRules.ag @@ -1,821 +1,821 @@ --- 13 okt 2011: eliminated the "multiRule" transformation for all but the Kastens-code --- the SELF types are also eliminated in this phase: in a Type value, there should not be --- a Self constructor anymore. - -PRAGMA strictdata -PRAGMA optimize -PRAGMA bangpats -PRAGMA strictwrap - -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "DistChildAttr.ag" - -imports -{ -import qualified Data.List -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq,(><)) -import UU.Scanner.Position(noPos) -import Pretty -import Data.Maybe -import HsToken -import HsTokenScanner -import Data.List(intersperse) -import Data.Char - -import AbstractSyntax -import ErrorMessages - -import Options -} - -------------------------------------------------------------------------------- --- Passing down corresponding nonterminal and constructor names -------------------------------------------------------------------------------- -ATTR Rule Rules Child Children Production Productions TypeSigs TypeSig Pattern Patterns [ nt:NontermIdent | | ] -ATTR Rule Rules Child Children Pattern Patterns [ con:ConstructorIdent | | ] - -ATTR Productions Production Children Child TypeSigs TypeSig [ params : {[Identifier]} | | ] -SEM Nonterminal | Nonterminal - prods.params = @params - - -------------------------------------------------------------------------------- --- Distributing options -------------------------------------------------------------------------------- - -ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule - [ options:{Options} - constructorTypeMap : {Map NontermIdent ConstructorType} | | ] -ATTR Nonterminals Nonterminal Productions Production [ o_rename:{Bool} - cr:Bool {- copy rule -} - | | ] - -ATTR Children Child [ cr:Bool {- copy rule -} | | ] -SEM Grammar - | Grammar nonts.o_rename = rename @lhs.options - nonts.cr = modcopy @lhs.options - -------------------------------------------------------------------------------- --- Passing down the set of wrapper names -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal Productions Production [ wrappers : {Set NontermIdent} | | ] -SEM Grammar | Grammar - nonts.wrappers = @wrappers - -------------------------------------------------------------------------------- --- Type synonyms environment -------------------------------------------------------------------------------- -ATTR Nonterminals Nonterminal Productions Production [ typeSyns : {TypeSyns} | | ] - - -------------------------------------------------------------------------------- --- some auxiliary functions -------------------------------------------------------------------------------- -{ -fieldName n = '@' : getName n - -locName n = "@loc." ++ getName n - -attrName fld attr - | fld == _LOC = locName attr - | fld == _FIELD = fieldName attr - | otherwise = '@' : getName fld ++ "." ++ getName attr - -_ACHILD = Ident "(" noPos -- hack - -mkLocVar = AGField _LOC - -isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool -isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor - -buildConExpr ocaml clean conmap typeSyns rename nt con1 fs' - | nt `elem` map fst typeSyns = if ocaml then synonymMl - else if clean then synonymClean - else synonymHs - | otherwise = normalExpr - where fs = map fst fs' - con = getName con1 - tup = " " ++ buildTuple fs - args = " " ++ unwords fs - normalExpr = if clean && isRecordConstructor nt conmap - then "{" ++ con ++ "|" ++ - unwords (intersperse "," $ map (\(new, old) -> getName old ++ " = " ++ new) fs') - ++ "}" - else conname' ++ args - - conname' | rename = getName nt ++ "_" ++ getName con1 - | otherwise = getName con1 - - synonymHs | con == "Tuple" = buildTuple fs - | con == "Cons" = "(:)" ++ args - | con == "Nil" = case lookup nt typeSyns of - Just (Map _ _) -> "Data.Map.empty" - Just (IntMap _) -> "Data.IntMap.empty" - Just (OrdSet _) -> "Data.Set.empty" - Just IntSet -> "Data.IntSet.empty" - _ -> "[]" - | con == "Just" = "Just" ++ args - | con == "Nothing" = "Nothing" - | con == "Entry" = ( case lookup nt typeSyns of - Just (Map _ _) -> "Data.Map.insert" - Just (IntMap _) -> "Data.IntMap.insert" - Just (OrdSet _) -> "Data.Set.insert" - Just IntSet -> "Data.IntSet.insert" ) ++ args - | otherwise = normalExpr - - synonymMl | con == "Tuple" = buildTuple fs - | con == "Cons" = "(::)" ++ tup - | con == "Nil" = case lookup nt typeSyns of - Just (Map _ _) -> prefixMod nt "empty" - Just (IntMap _) -> prefixMod nt "empty" - Just (OrdSet _) -> prefixMod nt "empty" - Just IntSet -> prefixMod nt "empty" - _ -> "[]" - | con == "Just" = "Some" ++ tup - | con == "Nothing" = "None" - | con == "Entry" = ( case lookup nt typeSyns of - Just (Map _ _) -> prefixMod nt "add" - Just (IntMap _) -> prefixMod nt "add" - Just (OrdSet _) -> prefixMod nt "add" - Just IntSet -> prefixMod nt "add" ) ++ args - | otherwise = normalExpr - - synonymClean | con == "Tuple" = buildTuple fs - | con == "Cons" = "(\\x xs -> [x:xs])" ++ args - | con == "Nil" = case lookup nt typeSyns of - Just (Map _ _) -> "Data.Map.empty" - Just (IntMap _) -> "Data.IntMap.empty" - Just (OrdSet _) -> "Data.Set.empty" - Just IntSet -> "Data.IntSet.empty" - _ -> "[]" - | con == "Just" = "Just" ++ args - | con == "Nothing" = "Nothing" - | con == "Entry" = ( case lookup nt typeSyns of - Just (Map _ _) -> "Data.Map.insert" - Just (IntMap _) -> "Data.IntMap.insert" - Just (OrdSet _) -> "Data.Set.insert" - Just IntSet -> "Data.IntSet.insert" ) ++ args - | otherwise = normalExpr - - - prefixMod nt nm = "M_" ++ getName nt ++ "." ++ nm - -concatSeq = foldr (Seq.><) Seq.empty - -splitAttrs :: Map Identifier a -> [Identifier] -> ([(Identifier,a)],[Identifier]) -- a used as (String,String) -splitAttrs _ [] - = ([],[]) -splitAttrs useMap (n:rest) - = let (uses,normals) = splitAttrs useMap rest - in case Map.lookup n useMap of - Just x -> ((n,x):uses , normals ) - Nothing -> ( uses , n:normals ) - -removeDefined :: Set (Identifier,Identifier) -> (Identifier,Attributes) -> (Identifier,[Identifier]) -removeDefined defined (fld,as) - = ( fld - , [ a - | a <- Map.keys as - , not (Set.member (fld,a) defined) - ] - ) - -} - -------------------------------------------------------------------------------- --- Errors -------------------------------------------------------------------------------- - -ATTR Grammar Nonterminals Nonterminal Productions Production - Child Children Rule Rules Pattern Patterns - [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ] - -------------------------------------------------------------------------------- --- Set of all defined nonterminals -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal [ || collect_nts USE {`Set.union`} {Set.empty} : {Set NontermIdent} ] -SEM Nonterminal - | Nonterminal lhs.collect_nts = Set.singleton @nt - -ATTR Nonterminals Nonterminal Productions Production [ nonterminals : {Set NontermIdent} || ] -SEM Grammar - | Grammar nonts.nonterminals = @nonts.collect_nts - -------------------------------------------------------------------------------- --- Pass down the lhs-attributes and the USE's to each alternative of a nonterminal -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal [ useMap : {UseMap} || ] -ATTR Productions Production [ inh, syn, inhOrig, synOrig : {Attributes} useMap : {Map Identifier (String,String,String)}|| ] - -SEM Nonterminal - | Nonterminal prods.inh = @loc.inh1 - prods.syn = @loc.syn1 - prods.inhOrig = @inh - prods.synOrig = @syn - prods.useMap = Map.findWithDefault Map.empty @nt @lhs.useMap - -SEM Production - | Production rules.con = @con - children.con = @con -SEM Child - | Child lhs . name = @name -SEM Grammar - | Grammar nonts . useMap = @useMap -SEM Grammar - | Grammar nonts . typeSyns = @typeSyns -SEM Nonterminal - | Nonterminal prods . nt = @nt - -SEM Child [ | | name:{Identifier} inherited,synthesized:{Attributes} ] - | Child lhs.inherited = @loc.inh1 - lhs.synthesized = if @name `Set.member` @lhs.merged - then Map.empty - else @loc.syn1 - -SEM Children [ | | inputs,outputs:{[(Identifier, Attributes)]} ] - | Cons lhs.inputs = (@hd.name, @hd.inherited) : @tl.inputs - .outputs = (@hd.name, @hd.synthesized) : @tl.outputs - | Nil lhs.inputs = [] - .outputs = [] - - - -------------------------------------------------------------------------------- --- Implementation of Use-rule and Copy-rule -------------------------------------------------------------------------------- - -{ - - - -deprecatedCopyRuleError nt con fld a - = let mesg = - "In the definitions for alternative" - >#< getName con - >#< "of nonterminal" - >#< getName nt - >|< "," - >-< "the value of field" - >#< getName a - >#< "is copied by a copy-rule." - >-< "Copying the value of a field using a copy-rule is deprecated" - >-< "Please add the following lines to your code:" - >-< ( "SEM" - >#< getName nt - >-< indent 2 ( "|" - >#< getName con - >#< getName fld - >#< "." - >#< a - >#< "=" - >#< "@" - >|< a - ) - ) - in CustomError True (getPos a) mesg - - -missingRuleErrorExpr clean nt con fld a - = (if clean then "abort" else "error") - ++ " \"missing rule: " - ++ show nt ++ "." ++ show con ++ "." - ++ show fld ++ "." ++ show a ++ "\"" - -makeRule :: (Identifier,Identifier) -> Expression -> String -> Bool -> Maybe Error -> Rule -makeRule (f1,a1) expr origin identity mbDelayedError - = Rule Nothing - (Alias f1 a1 (Underscore noPos)) - expr - False - origin - False - True - identity - mbDelayedError - False - - -useRule :: Options -> Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule -useRule opts locals ch_outs (n,(op,e,pos)) - = let elems = [ fld - | (fld,as) <- ch_outs - , Map.member n as - ] - - isOp [] = False - isOp (c:cs) - | isSpace c = isOp cs - | isAlpha c = case dropWhile isAlpha cs of - ('.':cs2) -> isOp cs2 -- fully qualified name, drop prefix - _ -> False - | c == '(' = False - | otherwise = True - - tks | Set.member n locals = [mkLocVar n noPos Nothing] - | null elems = lexTokens opts noPos e - | otherwise = lexTokens opts noPos str - where - opExpr l r - | isOp op = l ++ " " ++ op ++ " " ++ r -- takes the associativity of the operator - | otherwise = "(" ++ op ++ " " ++ l ++ " " ++ r ++ ")" -- associates to the right - str = foldr1 opExpr (map (flip attrName n) elems) - - in makeRule (_LHS,n) - (Expression noPos tks) - ("use rule " ++ pos) - False - Nothing - - -selfRule :: Bool -> Identifier -> [HsToken] -> Rule -selfRule lhsNecLoc attr tks - = makeRule (if lhsNecLoc then _LHS else _LOC,attr) - (Expression noPos tks) - "self rule" - False - Nothing - - - - -concatRE rsess = let (rss,ess) = unzip rsess - in (concat rss, concatSeq ess) - - -copyRule :: Options -> Set NontermIdent -> Identifier -> Identifier -> Bool -> Set Identifier -> (Map Identifier Identifier, (Identifier,[Identifier])) -> ([Rule], Seq Error) -copyRule options wrappers nt con modcopy locals (env,(fld,as)) - = concatRE (map copyRu as) - - where - copyRu a - = ( [ makeRule (fld,a) - (Expression noPos tks) - (cruletxt sel) - True - mbDelayedErr - ] - , err - ) - - where - sel - | not modcopy - && Set.member a locals = Just _LOC - | otherwise = Map.lookup a env - - (tks,err,mbDelayedErr) - = case sel of - Nothing -> let tks = [HsToken (missingRuleErrorExpr (clean options) nt con fld a) noPos] - err = MissingRule nt con fld a - in if nt `Set.member` wrappers && kennedyWarren options - then (tks, Seq.empty, Just err) -- yield error only if the rule is actually scheduled; for kennedyWarren code gen only - else (tks, Seq.singleton err, Nothing) - Just f - | f == _ACHILD -> ( [AGLocal a noPos Nothing] - , Seq.singleton (deprecatedCopyRuleError nt con fld a) - , Nothing - ) - | otherwise -> ( [AGField f a noPos Nothing] - , Seq.empty - , Nothing - ) - - cruletxt sel - | local = "copy rule (from local)" - | deprChild = "deprecated child copy" - | Set.member a locals && nonlocal = "modified copy rule" - | incoming && outgoing = "copy rule (chain)" - | incoming = "copy rule (down)" - | outgoing = "copy rule (up)" - | otherwise = "copy rule (chain)" - where outgoing = fld == _LHS - incoming = maybe False (== _LHS) sel - nonlocal = maybe False (/= _LOC) sel - local = maybe False (== _LOC) sel - deprChild = maybe False (== _ACHILD) sel -} - - - - -SEM Production - | Production - - lhs.errors = @children.errors >< @errs >< @rules.errors >< @loc.orderErrs - - loc.(newRls, errs) - = - let locals = @rules.locals - initenv = Map.fromList ( [ (a,_ACHILD) -- _ACHILD is used to mark identifiers in the environment that are terminals - | (a,_,_) <- @children.fields - ] - ++ attrs(_LHS, @lhs.inh) - ++ [ (a,_LOC) - | a <- Set.toList locals - ] - ) - - attrs (n,as) = [ (a,n) | a <- Map.keys as ] - - envs = scanl (flip Map.union) - initenv - (map (Map.fromList . attrs ) @children.outputs) - - child_envs = init envs - lhs_env = last envs - - (selfAttrs, normalAttrs) - = Map.partitionWithKey (\k _ -> maybe False isSELFNonterminal $ Map.lookup k @lhs.synOrig) @lhs.syn - - (_,undefAttrs) - = removeDefined @rules.definedAttrs (_LHS, normalAttrs) - - (useAttrs,others) - = splitAttrs @lhs.useMap undefAttrs - - (rules1, errors1) - = concatRE $ map (copyRule @lhs.options @lhs.wrappers @lhs.nt @con @lhs.cr locals) - (zip envs (map (removeDefined @rules.definedAttrs) @children.inputs)) - - uRules - = map (useRule @lhs.options locals @children.outputs) useAttrs - - -- creates a loc.xxx if there is a synthesized attr xxx of type SELF and no - -- loc.xxx exists yet. If there exists a terminal yyy and a local loc.yyy, then - -- the local is chosen as value for the terminal. - selfLocRules - = [ selfRule False attr $ - lexTokens @lhs.options noPos $ -- building a string and lexing it again is not so nice... but practical here - constructor [(childSelf attr nm tp, nm) | (nm,tp,virt) <- @children.fields, childExists virt] - | attr <- Map.keys selfAttrs - , not (Set.member attr locals) - ] - where - childSelf self nm tp - = case tp of NT nt _ _ -> attrName nm self - _ | nm `Set.member` locals -> locName nm - | otherwise -> fieldName nm - constructor fs - = buildConExpr (ocaml @lhs.options) (clean @lhs.options) @lhs.constructorTypeMap @lhs.typeSyns @lhs.o_rename @lhs.nt @con fs - - childExists ChildAttr = False - childExists _ = True - - selfRules - = [ selfRule True attr [mkLocVar attr noPos Nothing] - | attr <- Map.keys selfAttrs - , not (Set.member (_LHS,attr) @rules.definedAttrs) - ] - - (rules5, errs5) - = copyRule @lhs.options - @lhs.wrappers - @lhs.nt - @con - @lhs.cr - locals - (lhs_env, (_LHS, others)) - in (uRules++selfLocRules++selfRules++rules5++rules1, errors1> [Rule] -> [Rule] -addAugments (_, exprs) rules - | null exprs = rules -addAugments (syn, exprs) rules - = [rule] ++ funRules ++ map modify rules - where - rule = Rule Nothing (Alias _LHS syn (Underscore noPos)) rhs False "augmented rule" False True False Nothing False - rhs = Expression noPos tks - tks = [ HsToken "foldr ($) " noPos, mkLocVar substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos] - funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames) - - substSyn = Ident (show syn ++ "_augmented_syn") (getPos syn) - funNames = zipWith (\i _ -> Ident (show syn ++ "_augmented_f" ++ show i) (getPos syn)) [1..] exprs - funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "augment function" False True False Nothing False) funNames exprs - - modify (Rule mbNm pat rhs owrt origin expl pure identity mbErr eager) - | containsSyn pat = Rule mbNm (modifyPat pat) rhs owrt origin expl pure identity mbErr eager - modify r = r - - containsSyn (Constr _ pats) = any containsSyn pats - containsSyn (Product _ pats) = any containsSyn pats - containsSyn (Irrefutable pat) = containsSyn pat - containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat - containsSyn _ = False - - modifyPat (Constr name pats) = Constr name (map modifyPat pats) - modifyPat (Product pos pats) = Product pos (map modifyPat pats) - modifyPat (Irrefutable pat) = Irrefutable (modifyPat pat) - modifyPat (Alias field attr pat) - | field == _LHS && attr == syn = Alias _LOC substSyn (modifyPat pat) - | otherwise = Alias field attr (modifyPat pat) - modifyPat p = p - --- adds the additional rules needed for around, which creates a sequence of --- rules that form a function that each transforms the semantics of a child --- before attaching the child. --- The rule defines a local attribute "_around" and is dependent --- on this attribute. -addArounds :: (Identifier, [Expression]) -> [Rule] -> [Rule] -addArounds (_, exprs) rules | null exprs = rules -addArounds (child, exprs) rules - = [rule] ++ funRules ++ rules - where - rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) rhs False "around rule" False True False Nothing False - rhs = Expression noPos tks - tks = [ HsToken "\\s -> foldr ($) s " noPos, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos] - funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames) - - childLoc = Ident (show child ++ "_around") (getPos child) - funNames = zipWith (\i _ -> Ident (show child ++ "_around_f" ++ show i) (getPos child)) [1..] exprs - funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "around function" False True False Nothing False) funNames exprs - --- adds the additional rules needed for merging. --- It produces for each merging child a rule with local attribute: "_merged". --- this rules takes the semantics of the first children and feeds it to the function --- represented by this attribute. This attribute then defines the semantics for --- the merging child. -addMerges :: (Identifier, (Identifier,[Identifier],Expression)) -> [Rule] -> [Rule] -addMerges (target,(_,_,expr)) rules - = rule : rules - where - rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) expr False "merge rule" False True False Nothing False - childLoc = Ident (show target ++ "_merge") (getPos target) -} - - -ATTR Rule Rules Pattern Patterns - [ | | locals USE {`Set.union`} {Set.empty} : {Set Identifier} - definedAttrs USE {`Set.union`} {Set.empty} : {Set (Identifier,Identifier)} - ] - - -SEM Pattern - | Alias lhs.definedAttrs = Set.insert (@field,@attr) @pat.definedAttrs - .locals = if @field == _LOC - then Set.insert @attr @pat.locals - else @pat.locals - -SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ] - | Cons lhs.fields = @hd.field : @tl.fields - | Nil lhs.fields = [] - -SEM Child [ | | field : { (Identifier,Type,ChildKind) } ] - | Child lhs.field = (@name,@tp,@kind) - -------------------------------------------------------------------------------- --- -------------------------------------------------------------------------------- -ATTR Rule Pattern Patterns [ || containsVars USE {||} {False} : Bool ] - -SEM Pattern - | Alias lhs.containsVars = True - -ATTR Rule [ | | isPure : Bool ] -SEM Rule | Rule lhs.isPure = @pure - -------------------------------------------------------------------------------- --- Eliminate SELF types -------------------------------------------------------------------------------- - -SEM Nonterminal | Nonterminal - loc.inh1 = Map.map (elimSelfId @nt @params) @inh - loc.syn1 = Map.map (elimSelfId @nt @params) @syn - -SEM Child | Child - (loc.nt, loc.params) = case @tp of - NT nt params _ -> (nt, params) - Self -> error ("The type of child " ++ show @name ++ " should not be a Self type.") - Haskell t -> (identifier t, []) -- should be ignored because the child is a terminal - loc.inh1 = Map.map (elimSelfStr @loc.nt @loc.params) @loc.inh - loc.syn1 = Map.map (elimSelfStr @loc.nt @loc.params) @loc.syn - -SEM TypeSig | TypeSig - loc.tp1 = elimSelfId @lhs.nt @lhs.params @tp - -{ -elimSelfId :: NontermIdent -> [Identifier] -> Type -> Type -elimSelfId nt args Self = NT nt (map getName args) False -elimSelfId _ _ tp = tp - -elimSelfStr :: NontermIdent -> [String] -> Type -> Type -elimSelfStr nt args Self = NT nt args False -elimSelfStr _ _ tp = tp -} - -------------------------------------------------------------------------------- --- Reconstructing the tree -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal Productions Production Rules Rule [ | uniq:Int | ] - -SEM Grammar - | Grammar nonts.uniq = 1 - -ATTR Grammar Nonterminals Nonterminal Productions - Production Children Child Rules Rule Pattern Patterns TypeSigs TypeSig - [ | | output:SELF ] - -ATTR Rule [ | | outputs:Rules ] - -SEM Nonterminal | Nonterminal - lhs.output = Nonterminal @nt @params @loc.inh1 @loc.syn1 @prods.output - -SEM Production - | Production - loc.extra1 = foldr addAugments (@rules.output ++ @newRls) (Map.assocs @loc.augmentsIn) - loc.extra2 = foldr addArounds @loc.extra1 (Map.assocs @loc.aroundsIn) - loc.extra3 = foldr addMerges @loc.extra2 (Map.assocs @loc.mergesIn) - lhs.output = Production @con @params @constraints @children.output @loc.extra3 @typeSigs.output @macro - -SEM Child | Child - lhs.output = Child @name @tp @kind - -SEM TypeSig | TypeSig - lhs.output = TypeSig @name @loc.tp1 - -SEM Rules - | Cons lhs.output = if @hd.containsVars && @hd.isPure then @hd.outputs ++ @tl.output else @tl.output - -- remove rules that define nothing and do not have side effects - -SEM Rule - | Rule (loc.output1, loc.mbAlias) = mkRuleAlias @loc.output - (loc.outputs, lhs.uniq) = if needsMultiRules @lhs.options -- check if this works for UHC - then multiRule @loc.output1 @lhs.uniq - else ([@loc.output1], @lhs.uniq) - lhs.outputs = maybe [] return @loc.mbAlias ++ @loc.outputs - -{ --- When a rule has a name, create an alias for a rule --- and a modified rule that refers to the alias --- Thus it removes rule names from rules -mkRuleAlias :: Rule -> (Rule, Maybe Rule) -mkRuleAlias r@(Rule Nothing _ _ _ _ _ _ _ _ _) = (r, Nothing) -mkRuleAlias (Rule (Just nm) pat expr owrt origin expl pure identity mbErr eager) = (r', Just alias) where - alias = Rule Nothing (Alias _LOC (Ident ("_rule_" ++ show nm) pos) (Underscore pos)) expr owrt origin expl pure identity mbErr eager - pos = getPos nm - expr' = Expression pos tks - tks = [mkLocVar (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))] - r' = Rule Nothing pat expr' owrt origin False True identity Nothing False -} - - --- Work towards removing the need of the "multiRule". --- It's currently only needed for the Kastens code generation -{ -needsMultiRules :: Options -> Bool -needsMultiRules opts = (visit opts || withCycle opts) && not (kennedyWarren opts) -} - -{ -{- -multiRule replaces - loc.(a,b) = e -by - loc.tup1 = e - loc.(a,_) = @loc.tup1 - loc.(_,b) = @loc.tup1 -It needs to thread a unique number for inventing names for the tuples. - -It also works for nested tuples: - loc.(a,(b,c)) = e -becomes - loc.tup1 = e - loc.(a,_) = @loc.tup1 - loc.(_,tup2) = @loc.tup1 - loc.(b,_) = @loc.tup2 - loc.(_,c) = @loc.tup2 --} - -multiRule :: Rule -> Int -> ([Rule], Int) -multiRule (Rule _ pat expr owrt origin expl pure identity mbErr eager) uniq - = let f :: Bool -> (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int)) - f expl' w e (Product pos pats) n - = let freshName = Ident ("_tup" ++ show n) pos - freshExpr = Expression pos freshTks - freshTks = [AGField _LOC freshName pos Nothing] - freshPat = Alias _LOC freshName (Underscore pos) - a = length pats - 1 - us b p = Product pos (replicate (a-b) (Underscore pos) ++ [p] ++ replicate b (Underscore pos)) - g :: Pattern -> ([Pattern],[Rule],Int) -> ([Pattern],[Rule],Int) - g p (xs1,rs1,n1) = let (x2,(rs2,n2)) = f False (us (length xs1)) freshExpr p n1 - in (x2:xs1, rs2++rs1, n2) - (xs9,rs9,n9) = foldr g ([], [], n+1) pats - in ( freshPat - , ( Rule Nothing (w freshPat) e owrt origin expl' True False mbErr eager : rs9 - , n9 - ) - ) - f expl' w e p n - = ( p - , ( [Rule Nothing (w p) e owrt origin expl' True False mbErr eager] - , n - ) - ) - in snd (f expl id expr pat uniq) - -} - -------------------------------------------------------------------------------- --- Check the order definitions -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal Productions Production [ manualAttrOrderMap : {AttrOrderMap} | | ] - -SEM Grammar - | Grammar - nonts.manualAttrOrderMap = @manualAttrOrderMap - -ATTR Rules Rule [ | | ruleNames USE {`Set.union`} {Set.empty} : {Set Identifier} ] - -SEM Rule | Rule lhs.ruleNames = case @mbName of - Nothing -> Set.empty - Just nm -> Set.singleton nm - -SEM Production - | Production - loc.orderDeps = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrOrderMap - - loc.orderErrs - = let chldOutMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.outputs ] - chldInMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.inputs ] - - -- a local attribute - -- or an inherited attribute of the production - -- or an out-attribute of a child - isInAttribute :: Identifier -> Identifier -> [Error] - isInAttribute fld nm - | fld == _LOC = if nm `Set.member` @rules.locals - then [] - else [UndefAttr @lhs.nt @con fld nm False] - | fld == _LHS = if nm `Map.member` @lhs.inh - then [] - else [UndefAttr @lhs.nt @con fld nm False] - | otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldOutMap) - then [] - else [UndefAttr @lhs.nt @con fld nm False] - - -- a local attribute - -- or a synthesized attribute of the production - -- or an in-attribute of a child - isOutAttribute :: Identifier -> Identifier -> [Error] - isOutAttribute fld nm - | fld == _LOC = if nm `Set.member` @rules.locals - then [] - else [UndefAttr @lhs.nt @con fld nm True] - | fld == _LHS = if nm `Map.member` @lhs.syn - then [] - else [UndefAttr @lhs.nt @con fld nm True] - | otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldInMap) - then [] - else [UndefAttr @lhs.nt @con fld nm True] - - existsRule nm = if nm `Set.member` @rules.ruleNames - then [] - else [MissingNamedRule @lhs.nt @con nm] - - checkIn (OccAttr fld nm) = isInAttribute fld nm - checkIn (OccRule nm) = existsRule nm - checkOut (OccAttr fld nm) = isOutAttribute fld nm - checkOut (OccRule nm) = existsRule nm - in Seq.fromList . concat $ - [ checkIn occA ++ checkOut occB - | (Dependency occA occB) <- @loc.orderDeps - ] - -------------------------------------------------------------------------------- --- Decompose augment -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ] -ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ] - -SEM Grammar | Grammar nonts.augmentsIn = @augmentsMap -SEM Nonterminal | Nonterminal loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn -SEM Production | Production loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn - -ATTR Nonterminals Nonterminal [ aroundsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ] -ATTR Productions Production [ aroundsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ] - -SEM Grammar | Grammar nonts.aroundsIn = @aroundsMap -SEM Nonterminal | Nonterminal loc.aroundsIn = Map.findWithDefault Map.empty @nt @lhs.aroundsIn -SEM Production | Production loc.aroundsIn = Map.findWithDefault Map.empty @con @lhs.aroundsIn - -ATTR Nonterminals Nonterminal [ mergesIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))} | | ] -ATTR Productions Production [ mergesIn : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))} | | ] -ATTR Children Child [ merged : {Set Identifier} | | ] - -SEM Grammar | Grammar nonts.mergesIn = @mergeMap -SEM Nonterminal | Nonterminal loc.mergesIn = Map.findWithDefault Map.empty @nt @lhs.mergesIn -SEM Production | Production loc.mergesIn = Map.findWithDefault Map.empty @con @lhs.mergesIn - loc.merged = Set.fromList [ c | (_,cs,_) <- Map.elems @loc.mergesIn, c <- cs ] +-- 13 okt 2011: eliminated the "multiRule" transformation for all but the Kastens-code +-- the SELF types are also eliminated in this phase: in a Type value, there should not be +-- a Self constructor anymore. + +PRAGMA strictdata +PRAGMA optimize +PRAGMA bangpats +PRAGMA strictwrap + +INCLUDE "AbstractSyntax.ag" +INCLUDE "Patterns.ag" +INCLUDE "DistChildAttr.ag" + +imports +{ +import qualified Data.List +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Sequence as Seq +import Data.Sequence(Seq,(><)) +import UU.Scanner.Position(noPos) +import Pretty +import Data.Maybe +import HsToken +import HsTokenScanner +import Data.List(intersperse) +import Data.Char + +import AbstractSyntax +import ErrorMessages + +import Options +} + +------------------------------------------------------------------------------- +-- Passing down corresponding nonterminal and constructor names +------------------------------------------------------------------------------- +ATTR Rule Rules Child Children Production Productions TypeSigs TypeSig Pattern Patterns [ nt:NontermIdent | | ] +ATTR Rule Rules Child Children Pattern Patterns [ con:ConstructorIdent | | ] + +ATTR Productions Production Children Child TypeSigs TypeSig [ params : {[Identifier]} | | ] +SEM Nonterminal | Nonterminal + prods.params = @params + + +------------------------------------------------------------------------------- +-- Distributing options +------------------------------------------------------------------------------- + +ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule + [ options:{Options} + constructorTypeMap : {Map NontermIdent ConstructorType} | | ] +ATTR Nonterminals Nonterminal Productions Production [ o_rename:{Bool} + cr:Bool {- copy rule -} + | | ] + +ATTR Children Child [ cr:Bool {- copy rule -} | | ] +SEM Grammar + | Grammar nonts.o_rename = rename @lhs.options + nonts.cr = modcopy @lhs.options + +------------------------------------------------------------------------------- +-- Passing down the set of wrapper names +------------------------------------------------------------------------------- + +ATTR Nonterminals Nonterminal Productions Production [ wrappers : {Set NontermIdent} | | ] +SEM Grammar | Grammar + nonts.wrappers = @wrappers + +------------------------------------------------------------------------------- +-- Type synonyms environment +------------------------------------------------------------------------------- +ATTR Nonterminals Nonterminal Productions Production [ typeSyns : {TypeSyns} | | ] + + +------------------------------------------------------------------------------- +-- some auxiliary functions +------------------------------------------------------------------------------- +{ +fieldName n = '@' : getName n + +locName n = "@loc." ++ getName n + +attrName fld attr + | fld == _LOC = locName attr + | fld == _FIELD = fieldName attr + | otherwise = '@' : getName fld ++ "." ++ getName attr + +_ACHILD = Ident "(" noPos -- hack + +mkLocVar = AGField _LOC + +isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool +isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor + +buildConExpr ocaml clean conmap typeSyns rename nt con1 fs' + | nt `elem` map fst typeSyns = if ocaml then synonymMl + else if clean then synonymClean + else synonymHs + | otherwise = normalExpr + where fs = map fst fs' + con = getName con1 + tup = " " ++ buildTuple fs + args = " " ++ unwords fs + normalExpr = if clean && isRecordConstructor nt conmap + then "{" ++ con ++ "|" ++ + unwords (intersperse "," $ map (\(new, old) -> getName old ++ " = " ++ new) fs') + ++ "}" + else conname' ++ args + + conname' | rename = getName nt ++ "_" ++ getName con1 + | otherwise = getName con1 + + synonymHs | con == "Tuple" = buildTuple fs + | con == "Cons" = "(:)" ++ args + | con == "Nil" = case lookup nt typeSyns of + Just (Map _ _) -> "Data.Map.empty" + Just (IntMap _) -> "Data.IntMap.empty" + Just (OrdSet _) -> "Data.Set.empty" + Just IntSet -> "Data.IntSet.empty" + _ -> "[]" + | con == "Just" = "Just" ++ args + | con == "Nothing" = "Nothing" + | con == "Entry" = ( case lookup nt typeSyns of + Just (Map _ _) -> "Data.Map.insert" + Just (IntMap _) -> "Data.IntMap.insert" + Just (OrdSet _) -> "Data.Set.insert" + Just IntSet -> "Data.IntSet.insert" ) ++ args + | otherwise = normalExpr + + synonymMl | con == "Tuple" = buildTuple fs + | con == "Cons" = "(::)" ++ tup + | con == "Nil" = case lookup nt typeSyns of + Just (Map _ _) -> prefixMod nt "empty" + Just (IntMap _) -> prefixMod nt "empty" + Just (OrdSet _) -> prefixMod nt "empty" + Just IntSet -> prefixMod nt "empty" + _ -> "[]" + | con == "Just" = "Some" ++ tup + | con == "Nothing" = "None" + | con == "Entry" = ( case lookup nt typeSyns of + Just (Map _ _) -> prefixMod nt "add" + Just (IntMap _) -> prefixMod nt "add" + Just (OrdSet _) -> prefixMod nt "add" + Just IntSet -> prefixMod nt "add" ) ++ args + | otherwise = normalExpr + + synonymClean | con == "Tuple" = buildTuple fs + | con == "Cons" = "(\\x xs -> [x:xs])" ++ args + | con == "Nil" = case lookup nt typeSyns of + Just (Map _ _) -> "Data.Map.empty" + Just (IntMap _) -> "Data.IntMap.empty" + Just (OrdSet _) -> "Data.Set.empty" + Just IntSet -> "Data.IntSet.empty" + _ -> "[]" + | con == "Just" = "Just" ++ args + | con == "Nothing" = "Nothing" + | con == "Entry" = ( case lookup nt typeSyns of + Just (Map _ _) -> "Data.Map.insert" + Just (IntMap _) -> "Data.IntMap.insert" + Just (OrdSet _) -> "Data.Set.insert" + Just IntSet -> "Data.IntSet.insert" ) ++ args + | otherwise = normalExpr + + + prefixMod nt nm = "M_" ++ getName nt ++ "." ++ nm + +concatSeq = foldr (Seq.><) Seq.empty + +splitAttrs :: Map Identifier a -> [Identifier] -> ([(Identifier,a)],[Identifier]) -- a used as (String,String) +splitAttrs _ [] + = ([],[]) +splitAttrs useMap (n:rest) + = let (uses,normals) = splitAttrs useMap rest + in case Map.lookup n useMap of + Just x -> ((n,x):uses , normals ) + Nothing -> ( uses , n:normals ) + +removeDefined :: Set (Identifier,Identifier) -> (Identifier,Attributes) -> (Identifier,[Identifier]) +removeDefined defined (fld,as) + = ( fld + , [ a + | a <- Map.keys as + , not (Set.member (fld,a) defined) + ] + ) + +} + +------------------------------------------------------------------------------- +-- Errors +------------------------------------------------------------------------------- + +ATTR Grammar Nonterminals Nonterminal Productions Production + Child Children Rule Rules Pattern Patterns + [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ] + +------------------------------------------------------------------------------- +-- Set of all defined nonterminals +------------------------------------------------------------------------------- + +ATTR Nonterminals Nonterminal [ || collect_nts USE {`Set.union`} {Set.empty} : {Set NontermIdent} ] +SEM Nonterminal + | Nonterminal lhs.collect_nts = Set.singleton @nt + +ATTR Nonterminals Nonterminal Productions Production [ nonterminals : {Set NontermIdent} || ] +SEM Grammar + | Grammar nonts.nonterminals = @nonts.collect_nts + +------------------------------------------------------------------------------- +-- Pass down the lhs-attributes and the USE's to each alternative of a nonterminal +------------------------------------------------------------------------------- + +ATTR Nonterminals Nonterminal [ useMap : {UseMap} || ] +ATTR Productions Production [ inh, syn, inhOrig, synOrig : {Attributes} useMap : {Map Identifier (String,String,String)}|| ] + +SEM Nonterminal + | Nonterminal prods.inh = @loc.inh1 + prods.syn = @loc.syn1 + prods.inhOrig = @inh + prods.synOrig = @syn + prods.useMap = Map.findWithDefault Map.empty @nt @lhs.useMap + +SEM Production + | Production rules.con = @con + children.con = @con +SEM Child + | Child lhs . name = @name +SEM Grammar + | Grammar nonts . useMap = @useMap +SEM Grammar + | Grammar nonts . typeSyns = @typeSyns +SEM Nonterminal + | Nonterminal prods . nt = @nt + +SEM Child [ | | name:{Identifier} inherited,synthesized:{Attributes} ] + | Child lhs.inherited = @loc.inh1 + lhs.synthesized = if @name `Set.member` @lhs.merged + then Map.empty + else @loc.syn1 + +SEM Children [ | | inputs,outputs:{[(Identifier, Attributes)]} ] + | Cons lhs.inputs = (@hd.name, @hd.inherited) : @tl.inputs + .outputs = (@hd.name, @hd.synthesized) : @tl.outputs + | Nil lhs.inputs = [] + .outputs = [] + + + +------------------------------------------------------------------------------- +-- Implementation of Use-rule and Copy-rule +------------------------------------------------------------------------------- + +{ + + + +deprecatedCopyRuleError nt con fld a + = let mesg = + "In the definitions for alternative" + >#< getName con + >#< "of nonterminal" + >#< getName nt + >|< "," + >-< "the value of field" + >#< getName a + >#< "is copied by a copy-rule." + >-< "Copying the value of a field using a copy-rule is deprecated" + >-< "Please add the following lines to your code:" + >-< ( "SEM" + >#< getName nt + >-< indent 2 ( "|" + >#< getName con + >#< getName fld + >#< "." + >#< a + >#< "=" + >#< "@" + >|< a + ) + ) + in CustomError True (getPos a) mesg + + +missingRuleErrorExpr clean nt con fld a + = (if clean then "abort" else "error") + ++ " \"missing rule: " + ++ show nt ++ "." ++ show con ++ "." + ++ show fld ++ "." ++ show a ++ "\"" + +makeRule :: (Identifier,Identifier) -> Expression -> String -> Bool -> Maybe Error -> Rule +makeRule (f1,a1) expr origin identity mbDelayedError + = Rule Nothing + (Alias f1 a1 (Underscore noPos)) + expr + False + origin + False + True + identity + mbDelayedError + False + + +useRule :: Options -> Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule +useRule opts locals ch_outs (n,(op,e,pos)) + = let elems = [ fld + | (fld,as) <- ch_outs + , Map.member n as + ] + + isOp [] = False + isOp (c:cs) + | isSpace c = isOp cs + | isAlpha c = case dropWhile isAlpha cs of + ('.':cs2) -> isOp cs2 -- fully qualified name, drop prefix + _ -> False + | c == '(' = False + | otherwise = True + + tks | Set.member n locals = [mkLocVar n noPos Nothing] + | null elems = lexTokens opts noPos e + | otherwise = lexTokens opts noPos str + where + opExpr l r + | isOp op = l ++ " " ++ op ++ " " ++ r -- takes the associativity of the operator + | otherwise = "(" ++ op ++ " " ++ l ++ " " ++ r ++ ")" -- associates to the right + str = foldr1 opExpr (map (flip attrName n) elems) + + in makeRule (_LHS,n) + (Expression noPos tks) + ("use rule " ++ pos) + False + Nothing + + +selfRule :: Bool -> Identifier -> [HsToken] -> Rule +selfRule lhsNecLoc attr tks + = makeRule (if lhsNecLoc then _LHS else _LOC,attr) + (Expression noPos tks) + "self rule" + False + Nothing + + + + +concatRE rsess = let (rss,ess) = unzip rsess + in (concat rss, concatSeq ess) + + +copyRule :: Options -> Set NontermIdent -> Identifier -> Identifier -> Bool -> Set Identifier -> (Map Identifier Identifier, (Identifier,[Identifier])) -> ([Rule], Seq Error) +copyRule options wrappers nt con modcopy locals (env,(fld,as)) + = concatRE (map copyRu as) + + where + copyRu a + = ( [ makeRule (fld,a) + (Expression noPos tks) + (cruletxt sel) + True + mbDelayedErr + ] + , err + ) + + where + sel + | not modcopy + && Set.member a locals = Just _LOC + | otherwise = Map.lookup a env + + (tks,err,mbDelayedErr) + = case sel of + Nothing -> let tks = [HsToken (missingRuleErrorExpr (clean options) nt con fld a) noPos] + err = MissingRule nt con fld a + in if nt `Set.member` wrappers && kennedyWarren options + then (tks, Seq.empty, Just err) -- yield error only if the rule is actually scheduled; for kennedyWarren code gen only + else (tks, Seq.singleton err, Nothing) + Just f + | f == _ACHILD -> ( [AGLocal a noPos Nothing] + , Seq.singleton (deprecatedCopyRuleError nt con fld a) + , Nothing + ) + | otherwise -> ( [AGField f a noPos Nothing] + , Seq.empty + , Nothing + ) + + cruletxt sel + | local = "copy rule (from local)" + | deprChild = "deprecated child copy" + | Set.member a locals && nonlocal = "modified copy rule" + | incoming && outgoing = "copy rule (chain)" + | incoming = "copy rule (down)" + | outgoing = "copy rule (up)" + | otherwise = "copy rule (chain)" + where outgoing = fld == _LHS + incoming = maybe False (== _LHS) sel + nonlocal = maybe False (/= _LOC) sel + local = maybe False (== _LOC) sel + deprChild = maybe False (== _ACHILD) sel +} + + + + +SEM Production + | Production + + lhs.errors = @children.errors >< @errs >< @rules.errors >< @loc.orderErrs + + loc.(newRls, errs) + = + let locals = @rules.locals + initenv = Map.fromList ( [ (a,_ACHILD) -- _ACHILD is used to mark identifiers in the environment that are terminals + | (a,_,_) <- @children.fields + ] + ++ attrs(_LHS, @lhs.inh) + ++ [ (a,_LOC) + | a <- Set.toList locals + ] + ) + + attrs (n,as) = [ (a,n) | a <- Map.keys as ] + + envs = scanl (flip Map.union) + initenv + (map (Map.fromList . attrs ) @children.outputs) + + child_envs = init envs + lhs_env = last envs + + (selfAttrs, normalAttrs) + = Map.partitionWithKey (\k _ -> maybe False isSELFNonterminal $ Map.lookup k @lhs.synOrig) @lhs.syn + + (_,undefAttrs) + = removeDefined @rules.definedAttrs (_LHS, normalAttrs) + + (useAttrs,others) + = splitAttrs @lhs.useMap undefAttrs + + (rules1, errors1) + = concatRE $ map (copyRule @lhs.options @lhs.wrappers @lhs.nt @con @lhs.cr locals) + (zip envs (map (removeDefined @rules.definedAttrs) @children.inputs)) + + uRules + = map (useRule @lhs.options locals @children.outputs) useAttrs + + -- creates a loc.xxx if there is a synthesized attr xxx of type SELF and no + -- loc.xxx exists yet. If there exists a terminal yyy and a local loc.yyy, then + -- the local is chosen as value for the terminal. + selfLocRules + = [ selfRule False attr $ + lexTokens @lhs.options noPos $ -- building a string and lexing it again is not so nice... but practical here + constructor [(childSelf attr nm tp, nm) | (nm,tp,virt) <- @children.fields, childExists virt] + | attr <- Map.keys selfAttrs + , not (Set.member attr locals) + ] + where + childSelf self nm tp + = case tp of NT nt _ _ -> attrName nm self + _ | nm `Set.member` locals -> locName nm + | otherwise -> fieldName nm + constructor fs + = buildConExpr (ocaml @lhs.options) (clean @lhs.options) @lhs.constructorTypeMap @lhs.typeSyns @lhs.o_rename @lhs.nt @con fs + + childExists ChildAttr = False + childExists _ = True + + selfRules + = [ selfRule True attr [mkLocVar attr noPos Nothing] + | attr <- Map.keys selfAttrs + , not (Set.member (_LHS,attr) @rules.definedAttrs) + ] + + (rules5, errs5) + = copyRule @lhs.options + @lhs.wrappers + @lhs.nt + @con + @lhs.cr + locals + (lhs_env, (_LHS, others)) + in (uRules++selfLocRules++selfRules++rules5++rules1, errors1> [Rule] -> [Rule] +addAugments (_, exprs) rules + | null exprs = rules +addAugments (syn, exprs) rules + = [rule] ++ funRules ++ map modify rules + where + rule = Rule Nothing (Alias _LHS syn (Underscore noPos)) rhs False "augmented rule" False True False Nothing False + rhs = Expression noPos tks + tks = [ HsToken "foldr ($) " noPos, mkLocVar substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos] + funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames) + + substSyn = Ident (show syn ++ "_augmented_syn") (getPos syn) + funNames = zipWith (\i _ -> Ident (show syn ++ "_augmented_f" ++ show i) (getPos syn)) [1..] exprs + funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "augment function" False True False Nothing False) funNames exprs + + modify (Rule mbNm pat rhs owrt origin expl pure identity mbErr eager) + | containsSyn pat = Rule mbNm (modifyPat pat) rhs owrt origin expl pure identity mbErr eager + modify r = r + + containsSyn (Constr _ pats) = any containsSyn pats + containsSyn (Product _ pats) = any containsSyn pats + containsSyn (Irrefutable pat) = containsSyn pat + containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat + containsSyn _ = False + + modifyPat (Constr name pats) = Constr name (map modifyPat pats) + modifyPat (Product pos pats) = Product pos (map modifyPat pats) + modifyPat (Irrefutable pat) = Irrefutable (modifyPat pat) + modifyPat (Alias field attr pat) + | field == _LHS && attr == syn = Alias _LOC substSyn (modifyPat pat) + | otherwise = Alias field attr (modifyPat pat) + modifyPat p = p + +-- adds the additional rules needed for around, which creates a sequence of +-- rules that form a function that each transforms the semantics of a child +-- before attaching the child. +-- The rule defines a local attribute "_around" and is dependent +-- on this attribute. +addArounds :: (Identifier, [Expression]) -> [Rule] -> [Rule] +addArounds (_, exprs) rules | null exprs = rules +addArounds (child, exprs) rules + = [rule] ++ funRules ++ rules + where + rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) rhs False "around rule" False True False Nothing False + rhs = Expression noPos tks + tks = [ HsToken "\\s -> foldr ($) s " noPos, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos] + funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames) + + childLoc = Ident (show child ++ "_around") (getPos child) + funNames = zipWith (\i _ -> Ident (show child ++ "_around_f" ++ show i) (getPos child)) [1..] exprs + funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "around function" False True False Nothing False) funNames exprs + +-- adds the additional rules needed for merging. +-- It produces for each merging child a rule with local attribute: "_merged". +-- this rules takes the semantics of the first children and feeds it to the function +-- represented by this attribute. This attribute then defines the semantics for +-- the merging child. +addMerges :: (Identifier, (Identifier,[Identifier],Expression)) -> [Rule] -> [Rule] +addMerges (target,(_,_,expr)) rules + = rule : rules + where + rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) expr False "merge rule" False True False Nothing False + childLoc = Ident (show target ++ "_merge") (getPos target) +} + + +ATTR Rule Rules Pattern Patterns + [ | | locals USE {`Set.union`} {Set.empty} : {Set Identifier} + definedAttrs USE {`Set.union`} {Set.empty} : {Set (Identifier,Identifier)} + ] + + +SEM Pattern + | Alias lhs.definedAttrs = Set.insert (@field,@attr) @pat.definedAttrs + .locals = if @field == _LOC + then Set.insert @attr @pat.locals + else @pat.locals + +SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ] + | Cons lhs.fields = @hd.field : @tl.fields + | Nil lhs.fields = [] + +SEM Child [ | | field : { (Identifier,Type,ChildKind) } ] + | Child lhs.field = (@name,@tp,@kind) + +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- +ATTR Rule Pattern Patterns [ || containsVars USE {||} {False} : Bool ] + +SEM Pattern + | Alias lhs.containsVars = True + +ATTR Rule [ | | isPure : Bool ] +SEM Rule | Rule lhs.isPure = @pure + +------------------------------------------------------------------------------- +-- Eliminate SELF types +------------------------------------------------------------------------------- + +SEM Nonterminal | Nonterminal + loc.inh1 = Map.map (elimSelfId @nt @params) @inh + loc.syn1 = Map.map (elimSelfId @nt @params) @syn + +SEM Child | Child + (loc.nt, loc.params) = case @tp of + NT nt params _ -> (nt, params) + Self -> error ("The type of child " ++ show @name ++ " should not be a Self type.") + Haskell t -> (identifier t, []) -- should be ignored because the child is a terminal + loc.inh1 = Map.map (elimSelfStr @loc.nt @loc.params) @loc.inh + loc.syn1 = Map.map (elimSelfStr @loc.nt @loc.params) @loc.syn + +SEM TypeSig | TypeSig + loc.tp1 = elimSelfId @lhs.nt @lhs.params @tp + +{ +elimSelfId :: NontermIdent -> [Identifier] -> Type -> Type +elimSelfId nt args Self = NT nt (map getName args) False +elimSelfId _ _ tp = tp + +elimSelfStr :: NontermIdent -> [String] -> Type -> Type +elimSelfStr nt args Self = NT nt args False +elimSelfStr _ _ tp = tp +} + +------------------------------------------------------------------------------- +-- Reconstructing the tree +------------------------------------------------------------------------------- + +ATTR Nonterminals Nonterminal Productions Production Rules Rule [ | uniq:Int | ] + +SEM Grammar + | Grammar nonts.uniq = 1 + +ATTR Grammar Nonterminals Nonterminal Productions + Production Children Child Rules Rule Pattern Patterns TypeSigs TypeSig + [ | | output:SELF ] + +ATTR Rule [ | | outputs:Rules ] + +SEM Nonterminal | Nonterminal + lhs.output = Nonterminal @nt @params @loc.inh1 @loc.syn1 @prods.output + +SEM Production + | Production + loc.extra1 = foldr addAugments (@rules.output ++ @newRls) (Map.assocs @loc.augmentsIn) + loc.extra2 = foldr addArounds @loc.extra1 (Map.assocs @loc.aroundsIn) + loc.extra3 = foldr addMerges @loc.extra2 (Map.assocs @loc.mergesIn) + lhs.output = Production @con @params @constraints @children.output @loc.extra3 @typeSigs.output @macro + +SEM Child | Child + lhs.output = Child @name @tp @kind + +SEM TypeSig | TypeSig + lhs.output = TypeSig @name @loc.tp1 + +SEM Rules + | Cons lhs.output = if @hd.containsVars && @hd.isPure then @hd.outputs ++ @tl.output else @tl.output + -- remove rules that define nothing and do not have side effects + +SEM Rule + | Rule (loc.output1, loc.mbAlias) = mkRuleAlias @loc.output + (loc.outputs, lhs.uniq) = if needsMultiRules @lhs.options -- check if this works for UHC + then multiRule @loc.output1 @lhs.uniq + else ([@loc.output1], @lhs.uniq) + lhs.outputs = maybe [] return @loc.mbAlias ++ @loc.outputs + +{ +-- When a rule has a name, create an alias for a rule +-- and a modified rule that refers to the alias +-- Thus it removes rule names from rules +mkRuleAlias :: Rule -> (Rule, Maybe Rule) +mkRuleAlias r@(Rule Nothing _ _ _ _ _ _ _ _ _) = (r, Nothing) +mkRuleAlias (Rule (Just nm) pat expr owrt origin expl pure identity mbErr eager) = (r', Just alias) where + alias = Rule Nothing (Alias _LOC (Ident ("_rule_" ++ show nm) pos) (Underscore pos)) expr owrt origin expl pure identity mbErr eager + pos = getPos nm + expr' = Expression pos tks + tks = [mkLocVar (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))] + r' = Rule Nothing pat expr' owrt origin False True identity Nothing False +} + + +-- Work towards removing the need of the "multiRule". +-- It's currently only needed for the Kastens code generation +{ +needsMultiRules :: Options -> Bool +needsMultiRules opts = (visit opts || withCycle opts) && not (kennedyWarren opts) +} + +{ +{- +multiRule replaces + loc.(a,b) = e +by + loc.tup1 = e + loc.(a,_) = @loc.tup1 + loc.(_,b) = @loc.tup1 +It needs to thread a unique number for inventing names for the tuples. + +It also works for nested tuples: + loc.(a,(b,c)) = e +becomes + loc.tup1 = e + loc.(a,_) = @loc.tup1 + loc.(_,tup2) = @loc.tup1 + loc.(b,_) = @loc.tup2 + loc.(_,c) = @loc.tup2 +-} + +multiRule :: Rule -> Int -> ([Rule], Int) +multiRule (Rule _ pat expr owrt origin expl pure identity mbErr eager) uniq + = let f :: Bool -> (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int)) + f expl' w e (Product pos pats) n + = let freshName = Ident ("_tup" ++ show n) pos + freshExpr = Expression pos freshTks + freshTks = [AGField _LOC freshName pos Nothing] + freshPat = Alias _LOC freshName (Underscore pos) + a = length pats - 1 + us b p = Product pos (replicate (a-b) (Underscore pos) ++ [p] ++ replicate b (Underscore pos)) + g :: Pattern -> ([Pattern],[Rule],Int) -> ([Pattern],[Rule],Int) + g p (xs1,rs1,n1) = let (x2,(rs2,n2)) = f False (us (length xs1)) freshExpr p n1 + in (x2:xs1, rs2++rs1, n2) + (xs9,rs9,n9) = foldr g ([], [], n+1) pats + in ( freshPat + , ( Rule Nothing (w freshPat) e owrt origin expl' True False mbErr eager : rs9 + , n9 + ) + ) + f expl' w e p n + = ( p + , ( [Rule Nothing (w p) e owrt origin expl' True False mbErr eager] + , n + ) + ) + in snd (f expl id expr pat uniq) + +} + +------------------------------------------------------------------------------- +-- Check the order definitions +------------------------------------------------------------------------------- + +ATTR Nonterminals Nonterminal Productions Production [ manualAttrOrderMap : {AttrOrderMap} | | ] + +SEM Grammar + | Grammar + nonts.manualAttrOrderMap = @manualAttrOrderMap + +ATTR Rules Rule [ | | ruleNames USE {`Set.union`} {Set.empty} : {Set Identifier} ] + +SEM Rule | Rule lhs.ruleNames = case @mbName of + Nothing -> Set.empty + Just nm -> Set.singleton nm + +SEM Production + | Production + loc.orderDeps = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrOrderMap + + loc.orderErrs + = let chldOutMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.outputs ] + chldInMap = Map.fromList [ (k, Map.keysSet s) | (k,s) <- @children.inputs ] + + -- a local attribute + -- or an inherited attribute of the production + -- or an out-attribute of a child + isInAttribute :: Identifier -> Identifier -> [Error] + isInAttribute fld nm + | fld == _LOC = if nm `Set.member` @rules.locals + then [] + else [UndefAttr @lhs.nt @con fld nm False] + | fld == _LHS = if nm `Map.member` @lhs.inh + then [] + else [UndefAttr @lhs.nt @con fld nm False] + | otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldOutMap) + then [] + else [UndefAttr @lhs.nt @con fld nm False] + + -- a local attribute + -- or a synthesized attribute of the production + -- or an in-attribute of a child + isOutAttribute :: Identifier -> Identifier -> [Error] + isOutAttribute fld nm + | fld == _LOC = if nm `Set.member` @rules.locals + then [] + else [UndefAttr @lhs.nt @con fld nm True] + | fld == _LHS = if nm `Map.member` @lhs.syn + then [] + else [UndefAttr @lhs.nt @con fld nm True] + | otherwise = if nm `Set.member` (Map.findWithDefault Set.empty fld chldInMap) + then [] + else [UndefAttr @lhs.nt @con fld nm True] + + existsRule nm = if nm `Set.member` @rules.ruleNames + then [] + else [MissingNamedRule @lhs.nt @con nm] + + checkIn (OccAttr fld nm) = isInAttribute fld nm + checkIn (OccRule nm) = existsRule nm + checkOut (OccAttr fld nm) = isOutAttribute fld nm + checkOut (OccRule nm) = existsRule nm + in Seq.fromList . concat $ + [ checkIn occA ++ checkOut occB + | (Dependency occA occB) <- @loc.orderDeps + ] + +------------------------------------------------------------------------------- +-- Decompose augment +------------------------------------------------------------------------------- + +ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ] +ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ] + +SEM Grammar | Grammar nonts.augmentsIn = @augmentsMap +SEM Nonterminal | Nonterminal loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn +SEM Production | Production loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn + +ATTR Nonterminals Nonterminal [ aroundsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} | | ] +ATTR Productions Production [ aroundsIn : {Map ConstructorIdent (Map Identifier [Expression])} | | ] + +SEM Grammar | Grammar nonts.aroundsIn = @aroundsMap +SEM Nonterminal | Nonterminal loc.aroundsIn = Map.findWithDefault Map.empty @nt @lhs.aroundsIn +SEM Production | Production loc.aroundsIn = Map.findWithDefault Map.empty @con @lhs.aroundsIn + +ATTR Nonterminals Nonterminal [ mergesIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression)))} | | ] +ATTR Productions Production [ mergesIn : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier],Expression))} | | ] +ATTR Children Child [ merged : {Set Identifier} | | ] + +SEM Grammar | Grammar nonts.mergesIn = @mergeMap +SEM Nonterminal | Nonterminal loc.mergesIn = Map.findWithDefault Map.empty @nt @lhs.mergesIn +SEM Production | Production loc.mergesIn = Map.findWithDefault Map.empty @con @lhs.mergesIn + loc.merged = Set.fromList [ c | (_,cs,_) <- Map.elems @loc.mergesIn, c <- cs ] diff --git a/src-ag/Desugar.ag b/src-ag/Desugar.ag --- a/src-ag/Desugar.ag +++ b/src-ag/Desugar.ag @@ -1,332 +1,332 @@ -PRAGMA strictdata -PRAGMA optimize -PRAGMA bangpats -PRAGMA strictwrap - -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "HsToken.ag" -INCLUDE "DistChildAttr.ag" - - -imports -{ -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq,(><)) -import UU.Scanner.Position(Pos(..)) -import Data.Maybe -import Data.List(intersperse) - -import AbstractSyntax -import ErrorMessages -import Options -import HsToken -import HsTokenScanner -import TokenDef -import CommonTypes -} - -WRAPPER HsTokensRoot - - -ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rule Rules Expression [ options:{Options} | | ] - -ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] - -ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression [ | | output : SELF ] - - -------------------------------------------------------------------------------- --- Deal with RHS -------------------------------------------------------------------------------- - -SEM Expression - | Expression - (loc.tks', lhs.errors) = let inh = Inh_HsTokensRoot { childInhs_Inh_HsTokensRoot = @lhs.childInhs - , childSyns_Inh_HsTokensRoot = @lhs.childSyns - , nt_Inh_HsTokensRoot = @lhs.nt - , con_Inh_HsTokensRoot = @lhs.con - , ruleDescr_Inh_HsTokensRoot = @lhs.ruleDescr - , useFieldIdent_Inh_HsTokensRoot = genUseTraces @lhs.options - } - sem = sem_HsTokensRoot (HsTokensRoot @tks) - syn = wrap_HsTokensRoot sem inh - in (tks_Syn_HsTokensRoot syn, errors_Syn_HsTokensRoot syn) - lhs.output = Expression @pos @tks' - - -ATTR HsTokensRoot HsTokens HsToken [ useFieldIdent : Bool | | ] - -ATTR HsToken HsTokens [ | addLines : Int | ] -SEM HsTokensRoot - | HsTokensRoot - tokens.addLines = 0 - -ATTR HsTokensRoot [ | | tks : {[HsToken]} ] -ATTR HsToken HsTokens [ | | tks : SELF ] - -SEM HsToken - | AGLocal - lhs.addLines = if @lhs.useFieldIdent - then @lhs.addLines + 1 - else @lhs.addLines - loc.tks = AGLocal @var (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing) - | AGField - loc.mField = findField @field @attr @lhs.childSyns - - loc.field' = maybe @field id @loc.mField - lhs.errors = maybe (Seq.singleton (UndefAttr @lhs.nt @lhs.con @field (Ident "" (getPos @field)) False)) (const Seq.empty) @loc.mField - - lhs.addLines = if @lhs.useFieldIdent || length (getName @field) < length (getName @loc.field') - then @lhs.addLines + 1 - else @lhs.addLines - - loc.tks = AGField @loc.field' @attr (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing) - | HsToken - loc.tks = HsToken @value (addl @lhs.addLines @pos) - | CharToken - loc.tks = CharToken @value (addl @lhs.addLines @pos) - | StrToken - loc.tks = StrToken @value (addl @lhs.addLines @pos) - | Err - loc.tks = Err @mesg (addl @lhs.addLines @pos) - -{ -addl :: Int -> Pos -> Pos -addl n (Pos l c f) = Pos (l+n) c f -} - - -------------------------------------------------------------------------------- --- Deal with LHS -------------------------------------------------------------------------------- - -SEM Pattern - | Alias - (loc.field', loc.err1) = maybeError @field (UndefAttr @lhs.nt @lhs.con (Ident "" (getPos @field)) @attr True) $ - findField @field @attr @lhs.childInhs - loc.err2 = if @loc.field' == @field - then Seq.empty - else if (@loc.field', @attr) `Set.member` @lhs.defs - then Seq.singleton $ DupRule @lhs.nt @lhs.con @field @attr @loc.field' - else Seq.empty - lhs.errors = @loc.err1 Seq.>< @loc.err2 Seq.>< @pat.errors - loc.output = Alias @loc.field' @attr @pat.output - - -------------------------------------------------------------------------------- --- Distribute attributes of children -------------------------------------------------------------------------------- - -ATTR Children Child [ | | childInhs, childSyns USE {++} {[]} : {[(Identifier, Identifier)]} ] -ATTR Rules Rule Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ childInhs, childSyns : {[(Identifier, Identifier)]} | | ] - -SEM Child - | Child - lhs.childInhs = [(i, @name) | i <- Map.keys @loc.inh ] - lhs.childSyns = [(s, @name) | s <- Map.keys @loc.syn ] - -{ -maybeError :: a -> Error -> Maybe a -> (a, Seq Error) -maybeError def err mb - = maybe (def, Seq.singleton err) (\r -> (r, Seq.empty)) mb - -findField :: Identifier -> Identifier -> [(Identifier,Identifier)] -> Maybe Identifier -findField fld attr list - | fld == _FIRST = f list - | fld == _LAST = f (reverse list) - | otherwise = Just fld - where - f = lookup attr -} - - -------------------------------------------------------------------------------- --- Distribute nt and con -------------------------------------------------------------------------------- - -ATTR Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ nt : NontermIdent | | ] -ATTR Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ con : ConstructorIdent | | ] - -SEM Nonterminal - | Nonterminal - prods.nt = @nt - -SEM Production - | Production - rules.con = @con - - -------------------------------------------------------------------------------- --- Distribute a pattern description -------------------------------------------------------------------------------- - -ATTR Expression HsTokensRoot HsToken HsTokens [ ruleDescr : String | | ] - -SEM Rule - | Rule - loc.ruleDescr = show @lhs.nt ++ " :: " ++ show @lhs.con ++ " :: " ++ (concat $ intersperse "," $ map (\(f,a) -> show f ++ "." ++ show a) $ Set.toList @pattern.defsCollect) - - -------------------------------------------------------------------------------- --- Distribute all defined attributes -------------------------------------------------------------------------------- - -ATTR Rule Rules Pattern Patterns [ | | defsCollect USE {`Set.union`} {Set.empty} : {Set (Identifier, Identifier)} ] -SEM Pattern - | Alias - loc.def = Set.singleton (@field, @attr) - lhs.defsCollect = @loc.def `Set.union` @pat.defsCollect - -ATTR Rule Rules Pattern Patterns [ defs : {Set (Identifier, Identifier)} | | ] -SEM Production - | Production - rules.defs = @rules.defsCollect - - -------------------------------------------------------------------------------- --- Collect a list of all attributes (that are not irrefutable) -------------------------------------------------------------------------------- - -ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns - [ | | allAttributes USE {`mergeAttributes`} {Map.empty} : {AttrMap} ] - -SEM Pattern - | Alias - lhs.allAttributes = (Map.singleton @lhs.nt $ Map.singleton @lhs.con $ Set.singleton (@field, @attr)) `mergeAttributes` @pat.allAttributes - | Irrefutable - lhs.allAttributes = Map.empty - -{ -mergeAttributes :: AttrMap -> AttrMap -> AttrMap -mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union -} - - -------------------------------------------------------------------------------- --- Distribute a list of attributes forced to irrefutables -------------------------------------------------------------------------------- - -ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns - [ forcedIrrefutables : {AttrMap} | | ] - -SEM Pattern - | Alias - lhs.output = if Set.member (@field, @attr) $ Map.findWithDefault Set.empty @lhs.con $ Map.findWithDefault Map.empty @lhs.nt $ @lhs.forcedIrrefutables - then Irrefutable @loc.output - else @loc.output - - -------------------------------------------------------------------------------- --- Decompose augment map and rebuild it -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} - | | augmentsOut USE {`Map.union`} {Map.empty} : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} ] -ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])} - | | augmentsOut USE {`Map.union`} {Map.empty} : {Map ConstructorIdent (Map Identifier [Expression])} ] - -SEM Grammar - | Grammar - nonts.augmentsIn = @augmentsMap - -SEM Nonterminal - | Nonterminal - loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn - loc.augmentsOut = Map.singleton @nt @prods.augmentsOut - -SEM Production - | Production - loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn - loc.augmentsOut = Map.singleton @con @loc.augmentsOut1 - - (loc.augmentErrs, loc.augmentsOut1) = Map.mapAccum (desugarExprs @lhs.options @lhs.nt @con @children.childInhs @children.childSyns) Seq.empty @loc.augmentsIn - -WRAPPER Expression - -{ -desugarExprs :: Options -> NontermIdent -> ConstructorIdent -> - [(Identifier, Identifier)] -> [(Identifier, Identifier)] -> - Seq Error -> [Expression] -> (Seq Error, [Expression]) -desugarExprs options nt con childInhs childSyns - = mapAccum (desugarExpr options nt con childInhs childSyns) - where mapAccum f e = foldr (\x (e0,xs) -> let (e1,x') = f e0 x in (e1, x:xs)) (e, []) - -desugarExpr :: Options -> NontermIdent -> ConstructorIdent -> - [(Identifier, Identifier)] -> [(Identifier, Identifier)] -> - Seq Error -> Expression -> (Seq Error, Expression) -desugarExpr options nt con childInhs childSyns errs expr - = (errs Seq.>< errors_Syn_Expression syn, output_Syn_Expression syn) - where - inh = Inh_Expression { childInhs_Inh_Expression = childInhs - , childSyns_Inh_Expression = childSyns - , con_Inh_Expression = con - , nt_Inh_Expression = nt - , options_Inh_Expression = options - , ruleDescr_Inh_Expression = "augment-rule" - } - sem = sem_Expression expr - syn = wrap_Expression sem inh -} - - -------------------------------------------------------------------------------- --- Errors of a production -------------------------------------------------------------------------------- - -SEM Production - | Production - lhs.errors = @rules.errors Seq.>< @loc.augmentErrs - -------------------------------------------------------------------------------- --- Support for late binding of higher order children -------------------------------------------------------------------------------- - -ATTR Grammar Nonterminals Nonterminal Productions Production Children Child [ mainName : {String} | | ] - -SEM Nonterminal | Nonterminal - loc.extraInh = addLateAttr @lhs.options @lhs.mainName - -{ -addLateAttr :: Options -> String -> Attributes -addLateAttr options mainName - | kennedyWarren options && lateHigherOrderBinding options = - let tp = lateBindingType mainName - in Map.singleton idLateBindingAttr tp - | otherwise = Map.empty -} - -------------------------------------------------------------------------------- --- Reconstruct the grammar -------------------------------------------------------------------------------- - -SEM Nonterminal | Nonterminal - lhs.output = Nonterminal - @nt @params - (@loc.extraInh `Map.union` @inh) - @syn - @prods.output - -SEM Child | Child - lhs.output = Child @name @tp @kind - -SEM Grammar - | Grammar - lhs.output = Grammar @typeSyns - @useMap - @derivings - @wrappers - @nonts.output - @pragmas - @manualAttrOrderMap - @paramMap - @contextMap - @quantMap - @uniqueMap - @nonts.augmentsOut - @aroundsMap - @mergeMap +PRAGMA strictdata +PRAGMA optimize +PRAGMA bangpats +PRAGMA strictwrap + +INCLUDE "AbstractSyntax.ag" +INCLUDE "Patterns.ag" +INCLUDE "Expression.ag" +INCLUDE "HsToken.ag" +INCLUDE "DistChildAttr.ag" + + +imports +{ +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Sequence as Seq +import Data.Sequence(Seq,(><)) +import UU.Scanner.Position(Pos(..)) +import Data.Maybe +import Data.List(intersperse) + +import AbstractSyntax +import ErrorMessages +import Options +import HsToken +import HsTokenScanner +import TokenDef +import CommonTypes +} + +WRAPPER HsTokensRoot + + +ATTR Grammar Nonterminals Nonterminal Productions Production Children Child Rule Rules Expression [ options:{Options} | | ] + +ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] + +ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression [ | | output : SELF ] + + +------------------------------------------------------------------------------- +-- Deal with RHS +------------------------------------------------------------------------------- + +SEM Expression + | Expression + (loc.tks', lhs.errors) = let inh = Inh_HsTokensRoot { childInhs_Inh_HsTokensRoot = @lhs.childInhs + , childSyns_Inh_HsTokensRoot = @lhs.childSyns + , nt_Inh_HsTokensRoot = @lhs.nt + , con_Inh_HsTokensRoot = @lhs.con + , ruleDescr_Inh_HsTokensRoot = @lhs.ruleDescr + , useFieldIdent_Inh_HsTokensRoot = genUseTraces @lhs.options + } + sem = sem_HsTokensRoot (HsTokensRoot @tks) + syn = wrap_HsTokensRoot sem inh + in (tks_Syn_HsTokensRoot syn, errors_Syn_HsTokensRoot syn) + lhs.output = Expression @pos @tks' + + +ATTR HsTokensRoot HsTokens HsToken [ useFieldIdent : Bool | | ] + +ATTR HsToken HsTokens [ | addLines : Int | ] +SEM HsTokensRoot + | HsTokensRoot + tokens.addLines = 0 + +ATTR HsTokensRoot [ | | tks : {[HsToken]} ] +ATTR HsToken HsTokens [ | | tks : SELF ] + +SEM HsToken + | AGLocal + lhs.addLines = if @lhs.useFieldIdent + then @lhs.addLines + 1 + else @lhs.addLines + loc.tks = AGLocal @var (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing) + | AGField + loc.mField = findField @field @attr @lhs.childSyns + + loc.field' = maybe @field id @loc.mField + lhs.errors = maybe (Seq.singleton (UndefAttr @lhs.nt @lhs.con @field (Ident "" (getPos @field)) False)) (const Seq.empty) @loc.mField + + lhs.addLines = if @lhs.useFieldIdent || length (getName @field) < length (getName @loc.field') + then @lhs.addLines + 1 + else @lhs.addLines + + loc.tks = AGField @loc.field' @attr (addl @lhs.addLines @pos) (if @lhs.useFieldIdent then Just @lhs.ruleDescr else Nothing) + | HsToken + loc.tks = HsToken @value (addl @lhs.addLines @pos) + | CharToken + loc.tks = CharToken @value (addl @lhs.addLines @pos) + | StrToken + loc.tks = StrToken @value (addl @lhs.addLines @pos) + | Err + loc.tks = Err @mesg (addl @lhs.addLines @pos) + +{ +addl :: Int -> Pos -> Pos +addl n (Pos l c f) = Pos (l+n) c f +} + + +------------------------------------------------------------------------------- +-- Deal with LHS +------------------------------------------------------------------------------- + +SEM Pattern + | Alias + (loc.field', loc.err1) = maybeError @field (UndefAttr @lhs.nt @lhs.con (Ident "" (getPos @field)) @attr True) $ + findField @field @attr @lhs.childInhs + loc.err2 = if @loc.field' == @field + then Seq.empty + else if (@loc.field', @attr) `Set.member` @lhs.defs + then Seq.singleton $ DupRule @lhs.nt @lhs.con @field @attr @loc.field' + else Seq.empty + lhs.errors = @loc.err1 Seq.>< @loc.err2 Seq.>< @pat.errors + loc.output = Alias @loc.field' @attr @pat.output + + +------------------------------------------------------------------------------- +-- Distribute attributes of children +------------------------------------------------------------------------------- + +ATTR Children Child [ | | childInhs, childSyns USE {++} {[]} : {[(Identifier, Identifier)]} ] +ATTR Rules Rule Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ childInhs, childSyns : {[(Identifier, Identifier)]} | | ] + +SEM Child + | Child + lhs.childInhs = [(i, @name) | i <- Map.keys @loc.inh ] + lhs.childSyns = [(s, @name) | s <- Map.keys @loc.syn ] + +{ +maybeError :: a -> Error -> Maybe a -> (a, Seq Error) +maybeError def err mb + = maybe (def, Seq.singleton err) (\r -> (r, Seq.empty)) mb + +findField :: Identifier -> Identifier -> [(Identifier,Identifier)] -> Maybe Identifier +findField fld attr list + | fld == _FIRST = f list + | fld == _LAST = f (reverse list) + | otherwise = Just fld + where + f = lookup attr +} + + +------------------------------------------------------------------------------- +-- Distribute nt and con +------------------------------------------------------------------------------- + +ATTR Productions Production Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ nt : NontermIdent | | ] +ATTR Rule Rules Pattern Patterns Expression HsTokensRoot HsToken HsTokens [ con : ConstructorIdent | | ] + +SEM Nonterminal + | Nonterminal + prods.nt = @nt + +SEM Production + | Production + rules.con = @con + + +------------------------------------------------------------------------------- +-- Distribute a pattern description +------------------------------------------------------------------------------- + +ATTR Expression HsTokensRoot HsToken HsTokens [ ruleDescr : String | | ] + +SEM Rule + | Rule + loc.ruleDescr = show @lhs.nt ++ " :: " ++ show @lhs.con ++ " :: " ++ (concat $ intersperse "," $ map (\(f,a) -> show f ++ "." ++ show a) $ Set.toList @pattern.defsCollect) + + +------------------------------------------------------------------------------- +-- Distribute all defined attributes +------------------------------------------------------------------------------- + +ATTR Rule Rules Pattern Patterns [ | | defsCollect USE {`Set.union`} {Set.empty} : {Set (Identifier, Identifier)} ] +SEM Pattern + | Alias + loc.def = Set.singleton (@field, @attr) + lhs.defsCollect = @loc.def `Set.union` @pat.defsCollect + +ATTR Rule Rules Pattern Patterns [ defs : {Set (Identifier, Identifier)} | | ] +SEM Production + | Production + rules.defs = @rules.defsCollect + + +------------------------------------------------------------------------------- +-- Collect a list of all attributes (that are not irrefutable) +------------------------------------------------------------------------------- + +ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns + [ | | allAttributes USE {`mergeAttributes`} {Map.empty} : {AttrMap} ] + +SEM Pattern + | Alias + lhs.allAttributes = (Map.singleton @lhs.nt $ Map.singleton @lhs.con $ Set.singleton (@field, @attr)) `mergeAttributes` @pat.allAttributes + | Irrefutable + lhs.allAttributes = Map.empty + +{ +mergeAttributes :: AttrMap -> AttrMap -> AttrMap +mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union +} + + +------------------------------------------------------------------------------- +-- Distribute a list of attributes forced to irrefutables +------------------------------------------------------------------------------- + +ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns + [ forcedIrrefutables : {AttrMap} | | ] + +SEM Pattern + | Alias + lhs.output = if Set.member (@field, @attr) $ Map.findWithDefault Set.empty @lhs.con $ Map.findWithDefault Map.empty @lhs.nt $ @lhs.forcedIrrefutables + then Irrefutable @loc.output + else @loc.output + + +------------------------------------------------------------------------------- +-- Decompose augment map and rebuild it +------------------------------------------------------------------------------- + +ATTR Nonterminals Nonterminal [ augmentsIn : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} + | | augmentsOut USE {`Map.union`} {Map.empty} : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} ] +ATTR Productions Production [ augmentsIn : {Map ConstructorIdent (Map Identifier [Expression])} + | | augmentsOut USE {`Map.union`} {Map.empty} : {Map ConstructorIdent (Map Identifier [Expression])} ] + +SEM Grammar + | Grammar + nonts.augmentsIn = @augmentsMap + +SEM Nonterminal + | Nonterminal + loc.augmentsIn = Map.findWithDefault Map.empty @nt @lhs.augmentsIn + loc.augmentsOut = Map.singleton @nt @prods.augmentsOut + +SEM Production + | Production + loc.augmentsIn = Map.findWithDefault Map.empty @con @lhs.augmentsIn + loc.augmentsOut = Map.singleton @con @loc.augmentsOut1 + + (loc.augmentErrs, loc.augmentsOut1) = Map.mapAccum (desugarExprs @lhs.options @lhs.nt @con @children.childInhs @children.childSyns) Seq.empty @loc.augmentsIn + +WRAPPER Expression + +{ +desugarExprs :: Options -> NontermIdent -> ConstructorIdent -> + [(Identifier, Identifier)] -> [(Identifier, Identifier)] -> + Seq Error -> [Expression] -> (Seq Error, [Expression]) +desugarExprs options nt con childInhs childSyns + = mapAccum (desugarExpr options nt con childInhs childSyns) + where mapAccum f e = foldr (\x (e0,xs) -> let (e1,x') = f e0 x in (e1, x:xs)) (e, []) + +desugarExpr :: Options -> NontermIdent -> ConstructorIdent -> + [(Identifier, Identifier)] -> [(Identifier, Identifier)] -> + Seq Error -> Expression -> (Seq Error, Expression) +desugarExpr options nt con childInhs childSyns errs expr + = (errs Seq.>< errors_Syn_Expression syn, output_Syn_Expression syn) + where + inh = Inh_Expression { childInhs_Inh_Expression = childInhs + , childSyns_Inh_Expression = childSyns + , con_Inh_Expression = con + , nt_Inh_Expression = nt + , options_Inh_Expression = options + , ruleDescr_Inh_Expression = "augment-rule" + } + sem = sem_Expression expr + syn = wrap_Expression sem inh +} + + +------------------------------------------------------------------------------- +-- Errors of a production +------------------------------------------------------------------------------- + +SEM Production + | Production + lhs.errors = @rules.errors Seq.>< @loc.augmentErrs + +------------------------------------------------------------------------------- +-- Support for late binding of higher order children +------------------------------------------------------------------------------- + +ATTR Grammar Nonterminals Nonterminal Productions Production Children Child [ mainName : {String} | | ] + +SEM Nonterminal | Nonterminal + loc.extraInh = addLateAttr @lhs.options @lhs.mainName + +{ +addLateAttr :: Options -> String -> Attributes +addLateAttr options mainName + | kennedyWarren options && lateHigherOrderBinding options = + let tp = lateBindingType mainName + in Map.singleton idLateBindingAttr tp + | otherwise = Map.empty +} + +------------------------------------------------------------------------------- +-- Reconstruct the grammar +------------------------------------------------------------------------------- + +SEM Nonterminal | Nonterminal + lhs.output = Nonterminal + @nt @params + (@loc.extraInh `Map.union` @inh) + @syn + @prods.output + +SEM Child | Child + lhs.output = Child @name @tp @kind + +SEM Grammar + | Grammar + lhs.output = Grammar @typeSyns + @useMap + @derivings + @wrappers + @nonts.output + @pragmas + @manualAttrOrderMap + @paramMap + @contextMap + @quantMap + @uniqueMap + @nonts.augmentsOut + @aroundsMap + @mergeMap diff --git a/src-ag/DistChildAttr.ag b/src-ag/DistChildAttr.ag --- a/src-ag/DistChildAttr.ag +++ b/src-ag/DistChildAttr.ag @@ -1,24 +1,24 @@ -------------------------------------------------------------------------------- --- Map of all inherited and synthesized attributes per nonterminal -------------------------------------------------------------------------------- -ATTR Nonterminals Nonterminal [ || inhMap', synMap' USE {`Map.union`} {Map.empty} : {Map Identifier Attributes} ] - -SEM Nonterminal - | Nonterminal lhs.inhMap' = Map.singleton @nt @inh - lhs.synMap' = Map.singleton @nt @syn - -ATTR Nonterminals Nonterminal - Productions Production - Children Child [ inhMap, synMap : {Map Identifier Attributes} | | ] - -SEM Grammar - | Grammar nonts.inhMap = @nonts.inhMap' - nonts.synMap = @nonts.synMap' - -SEM Child - | Child loc.chnt = case @tp of - NT nt _ _ -> nt - Self -> error ("The type of child " ++ show @name ++ " should not be a Self type.") - Haskell t -> identifier "" -- should be ignored because the child is a terminal - loc.inh = Map.findWithDefault Map.empty @loc.chnt @lhs.inhMap - loc.syn = Map.findWithDefault Map.empty @loc.chnt @lhs.synMap +------------------------------------------------------------------------------- +-- Map of all inherited and synthesized attributes per nonterminal +------------------------------------------------------------------------------- +ATTR Nonterminals Nonterminal [ || inhMap', synMap' USE {`Map.union`} {Map.empty} : {Map Identifier Attributes} ] + +SEM Nonterminal + | Nonterminal lhs.inhMap' = Map.singleton @nt @inh + lhs.synMap' = Map.singleton @nt @syn + +ATTR Nonterminals Nonterminal + Productions Production + Children Child [ inhMap, synMap : {Map Identifier Attributes} | | ] + +SEM Grammar + | Grammar nonts.inhMap = @nonts.inhMap' + nonts.synMap = @nonts.synMap' + +SEM Child + | Child loc.chnt = case @tp of + NT nt _ _ -> nt + Self -> error ("The type of child " ++ show @name ++ " should not be a Self type.") + Haskell t -> identifier "" -- should be ignored because the child is a terminal + loc.inh = Map.findWithDefault Map.empty @loc.chnt @lhs.inhMap + loc.syn = Map.findWithDefault Map.empty @loc.chnt @lhs.synMap diff --git a/src-ag/ErrorMessages.ag b/src-ag/ErrorMessages.ag --- a/src-ag/ErrorMessages.ag +++ b/src-ag/ErrorMessages.ag @@ -1,148 +1,148 @@ -imports -{ -import UU.Scanner.Position(Pos) -import Pretty -import CodeSyntax -import CommonTypes -} - -TYPE Errors = [Error] - -DATA Error | ParserError pos : {Pos} - problem : {String} - action : {String} - - | HsParseError pos : {Pos} - msg : {String} - - | DupAlt nt : {NontermIdent} - con,occ1 : {ConstructorIdent} - - | DupSynonym nt,occ1 : {NontermIdent} - - | DupSet name,occ1 : {NontermIdent} - - | DupInhAttr nt : {NontermIdent} - attr,occ1 :{Identifier} - - | DupSynAttr nt : {NontermIdent} - attr,occ1 : {Identifier} - - | DupChild nt : {NontermIdent} - con : {ConstructorIdent} - name,occ1 : {Identifier} - - | DupRule nt : {NontermIdent} - con : {ConstructorIdent} - field : {Identifier} - attr,occ1 : {Identifier} - - | DupRuleName nt : {NontermIdent} - con : {ConstructorIdent} - nm : {Identifier} - - | DupSig nt : {NontermIdent} - con : {ConstructorIdent} - attr : {Identifier} - - | UndefNont nt : {NontermIdent} - - | UndefAlt nt : {NontermIdent} - con : {ConstructorIdent} - - | UndefChild nt : {NontermIdent} - con : {ConstructorIdent} - name : {Identifier} - - | MissingRule --pos : {Pos} - nt : {NontermIdent} - con : {ConstructorIdent} - field : {Identifier} - attr : {Identifier} - - | MissingNamedRule nt : {NontermIdent} - con : {Identifier} - name : {Identifier} - - | SuperfluousRule nt : {NontermIdent} - con : {ConstructorIdent} - field : {Identifier} - attr : {Identifier} - --- | SuperfluousSig nt : {NontermIdent} --- con : {ConstructorIdent} --- attr : {Identifier} - - | UndefLocal nt : {NontermIdent} - con : {ConstructorIdent} - var : {Identifier} - - | ChildAsLocal nt : {NontermIdent} - con : {ConstructorIdent} - var : {Identifier} - - | UndefAttr nt : {NontermIdent} - con : {ConstructorIdent} - field : {Identifier} - attr : {Identifier} - isOut : {Bool} - - | Cyclic nt : {NontermIdent} - mbCon : {Maybe ConstructorIdent} - verts : {[String]} - - | CyclicSet name:{Identifier} - - | CustomError isWarning : {Bool} - pos : {Pos} - mesg : {PP_Doc} - - | LocalCirc nt : {NontermIdent} - con : {ConstructorIdent} - attr : {Identifier} - o_visit : {Bool} - path : {[String]} - - | InstCirc nt : {NontermIdent} - con : {ConstructorIdent} - attr : {Identifier} - o_visit : {Bool} - path : {[String]} - - | DirectCirc nt : {NontermIdent} - o_visit : {Bool} - cyclic : {[((Identifier,Identifier),[String],[String])]} - - | InducedCirc nt : {NontermIdent} - cinter : {CInterface} - cyclic : {[((Identifier,Identifier),[String],[String])]} - - | MissingTypeSig nt : {NontermIdent} - con : {ConstructorIdent} - attr : {Identifier} - - | MissingInstSig nt : {NontermIdent} - con : {ConstructorIdent} - attr : {Identifier} - - | DupUnique nt : {NontermIdent} - con : {ConstructorIdent} - attr : {Identifier} - - | MissingUnique nt : {NontermIdent} - attr : {Identifier} - - | MissingSyn nt : {NontermIdent} - attr : {Identifier} - - | IncompatibleVisitKind - child : {Identifier} - vis : {VisitIdentifier} - from : {VisitKind} - to : {VisitKind} - | IncompatibleRuleKind - rule : {Identifier} - kind : {VisitKind} - | IncompatibleAttachKind - child : {Identifier} - kind : {VisitKind} +imports +{ +import UU.Scanner.Position(Pos) +import Pretty +import CodeSyntax +import CommonTypes +} + +TYPE Errors = [Error] + +DATA Error | ParserError pos : {Pos} + problem : {String} + action : {String} + + | HsParseError pos : {Pos} + msg : {String} + + | DupAlt nt : {NontermIdent} + con,occ1 : {ConstructorIdent} + + | DupSynonym nt,occ1 : {NontermIdent} + + | DupSet name,occ1 : {NontermIdent} + + | DupInhAttr nt : {NontermIdent} + attr,occ1 :{Identifier} + + | DupSynAttr nt : {NontermIdent} + attr,occ1 : {Identifier} + + | DupChild nt : {NontermIdent} + con : {ConstructorIdent} + name,occ1 : {Identifier} + + | DupRule nt : {NontermIdent} + con : {ConstructorIdent} + field : {Identifier} + attr,occ1 : {Identifier} + + | DupRuleName nt : {NontermIdent} + con : {ConstructorIdent} + nm : {Identifier} + + | DupSig nt : {NontermIdent} + con : {ConstructorIdent} + attr : {Identifier} + + | UndefNont nt : {NontermIdent} + + | UndefAlt nt : {NontermIdent} + con : {ConstructorIdent} + + | UndefChild nt : {NontermIdent} + con : {ConstructorIdent} + name : {Identifier} + + | MissingRule --pos : {Pos} + nt : {NontermIdent} + con : {ConstructorIdent} + field : {Identifier} + attr : {Identifier} + + | MissingNamedRule nt : {NontermIdent} + con : {Identifier} + name : {Identifier} + + | SuperfluousRule nt : {NontermIdent} + con : {ConstructorIdent} + field : {Identifier} + attr : {Identifier} + +-- | SuperfluousSig nt : {NontermIdent} +-- con : {ConstructorIdent} +-- attr : {Identifier} + + | UndefLocal nt : {NontermIdent} + con : {ConstructorIdent} + var : {Identifier} + + | ChildAsLocal nt : {NontermIdent} + con : {ConstructorIdent} + var : {Identifier} + + | UndefAttr nt : {NontermIdent} + con : {ConstructorIdent} + field : {Identifier} + attr : {Identifier} + isOut : {Bool} + + | Cyclic nt : {NontermIdent} + mbCon : {Maybe ConstructorIdent} + verts : {[String]} + + | CyclicSet name:{Identifier} + + | CustomError isWarning : {Bool} + pos : {Pos} + mesg : {PP_Doc} + + | LocalCirc nt : {NontermIdent} + con : {ConstructorIdent} + attr : {Identifier} + o_visit : {Bool} + path : {[String]} + + | InstCirc nt : {NontermIdent} + con : {ConstructorIdent} + attr : {Identifier} + o_visit : {Bool} + path : {[String]} + + | DirectCirc nt : {NontermIdent} + o_visit : {Bool} + cyclic : {[((Identifier,Identifier),[String],[String])]} + + | InducedCirc nt : {NontermIdent} + cinter : {CInterface} + cyclic : {[((Identifier,Identifier),[String],[String])]} + + | MissingTypeSig nt : {NontermIdent} + con : {ConstructorIdent} + attr : {Identifier} + + | MissingInstSig nt : {NontermIdent} + con : {ConstructorIdent} + attr : {Identifier} + + | DupUnique nt : {NontermIdent} + con : {ConstructorIdent} + attr : {Identifier} + + | MissingUnique nt : {NontermIdent} + attr : {Identifier} + + | MissingSyn nt : {NontermIdent} + attr : {Identifier} + + | IncompatibleVisitKind + child : {Identifier} + vis : {VisitIdentifier} + from : {VisitKind} + to : {VisitKind} + | IncompatibleRuleKind + rule : {Identifier} + kind : {VisitKind} + | IncompatibleAttachKind + child : {Identifier} + kind : {VisitKind} diff --git a/src-ag/ExecutionPlan.ag b/src-ag/ExecutionPlan.ag --- a/src-ag/ExecutionPlan.ag +++ b/src-ag/ExecutionPlan.ag @@ -1,83 +1,83 @@ -imports -{ --- VisitSyntax.ag imports -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import CommonTypes -import ErrorMessages - -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Map as Map -import Data.Map(Map) -} - -DATA ExecutionPlan | ExecutionPlan nonts : ENonterminals - typeSyns : {TypeSyns} - wrappers : {Set NontermIdent} - derivings : {Derivings} - -TYPE ENonterminals = [ENonterminal] - -TYPE EProductions = [EProduction] - -TYPE ERules = [ERule] - -TYPE EChildren = [EChild] - -TYPE VisitSteps = [VisitStep] - -TYPE Visits = [Visit] - -DATA ENonterminal | ENonterminal nt : {NontermIdent} - params : {[Identifier]} - classCtxs : {ClassContext} -- class context at the datatype level - initial : {StateIdentifier} - initialv : {[VisitIdentifier]} - nextVisits : {Map StateIdentifier StateCtx} -- info about the next visits from a given state - prevVisits : {Map StateIdentifier StateCtx} -- info about the previous visits to a given state - prods : EProductions - recursive : {Bool} - hoInfo : {HigherOrderInfo} - -DATA EProduction | EProduction con : {ConstructorIdent} - params : {[Identifier]} - constraints : {[Type]} -- (class/equality) constraints on types (requires GADTs) - rules : ERules - children : EChildren - visits : Visits - -DATA EChild | EChild name : {Identifier} - tp : {Type} - kind : {ChildKind} - hasAround : {Bool} -- if there exists a rule _around that transforms the child's sem - merges : {Maybe [Identifier]} -- Nothing: not the result of a merge of other children (ignored for now) - isMerged : {Bool} -- False: not being used to merge other children (ignored for now) - | ETerm name : {Identifier} - tp : {Type} - -DATA ERule | ERule name : {Identifier} - pattern : Pattern - rhs : Expression - owrt : {Bool} - origin : String -- just for documentation (and maybe errors) - explicit : Bool -- True if this rule defined in the source code - pure : Bool -- True if this rule is pure (not monadic/no side effect) - mbError : {Maybe Error} -- the rule may contain an error that is yielded when the rule is scheduled - -DATA Visit | Visit ident : {VisitIdentifier} - from : {StateIdentifier} - to : {StateIdentifier} - inh : {Set Identifier} - syn : {Set Identifier} - steps : VisitSteps - kind : {VisitKind} - -DATA VisitStep | Sem name : {Identifier} - | ChildVisit child : {Identifier} - nonterm : {NontermIdent} - visit : {VisitIdentifier} - | PureGroup steps : VisitSteps -- A group of steps that should be executed purely - ordered : {Bool} - | Sim steps : VisitSteps - | ChildIntro child : {Identifier} +imports +{ +-- VisitSyntax.ag imports +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes +import ErrorMessages + +import qualified Data.Set as Set +import Data.Set(Set) +import qualified Data.Map as Map +import Data.Map(Map) +} + +DATA ExecutionPlan | ExecutionPlan nonts : ENonterminals + typeSyns : {TypeSyns} + wrappers : {Set NontermIdent} + derivings : {Derivings} + +TYPE ENonterminals = [ENonterminal] + +TYPE EProductions = [EProduction] + +TYPE ERules = [ERule] + +TYPE EChildren = [EChild] + +TYPE VisitSteps = [VisitStep] + +TYPE Visits = [Visit] + +DATA ENonterminal | ENonterminal nt : {NontermIdent} + params : {[Identifier]} + classCtxs : {ClassContext} -- class context at the datatype level + initial : {StateIdentifier} + initialv : {[VisitIdentifier]} + nextVisits : {Map StateIdentifier StateCtx} -- info about the next visits from a given state + prevVisits : {Map StateIdentifier StateCtx} -- info about the previous visits to a given state + prods : EProductions + recursive : {Bool} + hoInfo : {HigherOrderInfo} + +DATA EProduction | EProduction con : {ConstructorIdent} + params : {[Identifier]} + constraints : {[Type]} -- (class/equality) constraints on types (requires GADTs) + rules : ERules + children : EChildren + visits : Visits + +DATA EChild | EChild name : {Identifier} + tp : {Type} + kind : {ChildKind} + hasAround : {Bool} -- if there exists a rule _around that transforms the child's sem + merges : {Maybe [Identifier]} -- Nothing: not the result of a merge of other children (ignored for now) + isMerged : {Bool} -- False: not being used to merge other children (ignored for now) + | ETerm name : {Identifier} + tp : {Type} + +DATA ERule | ERule name : {Identifier} + pattern : Pattern + rhs : Expression + owrt : {Bool} + origin : String -- just for documentation (and maybe errors) + explicit : Bool -- True if this rule defined in the source code + pure : Bool -- True if this rule is pure (not monadic/no side effect) + mbError : {Maybe Error} -- the rule may contain an error that is yielded when the rule is scheduled + +DATA Visit | Visit ident : {VisitIdentifier} + from : {StateIdentifier} + to : {StateIdentifier} + inh : {Set Identifier} + syn : {Set Identifier} + steps : VisitSteps + kind : {VisitKind} + +DATA VisitStep | Sem name : {Identifier} + | ChildVisit child : {Identifier} + nonterm : {NontermIdent} + visit : {VisitIdentifier} + | PureGroup steps : VisitSteps -- A group of steps that should be executed purely + ordered : {Bool} + | Sim steps : VisitSteps + | ChildIntro child : {Identifier} diff --git a/src-ag/ExecutionPlan2Caml.ag b/src-ag/ExecutionPlan2Caml.ag --- a/src-ag/ExecutionPlan2Caml.ag +++ b/src-ag/ExecutionPlan2Caml.ag @@ -1,1487 +1,1487 @@ --- As expected, the code generation for ML resembles the code generation for Haskell quite a bit. --- However, there are several differences: --- * no inline pragmas --- * no strictness annotations (not needed) --- * separating data types from code --- --- Generator conventions: --- * we generate functions definitions with an 'and' binding and a match statement --- * for some type aliasses, we'll introduce module decls in addition to a type --- --- Future work: --- * abuse the module system more? --- * parse ocaml blocks? --- * lazy evaluation? --- --- Other comments: --- * Empty records are not allowed in Ocaml. Mapping them to units. --- * line pragmas. There are now line pragmas around the body of rules. --- There cannot be syntactical mistakes in the patterns. However, there can be --- type errors if a function returns a value with a type that differs from what --- is expected. It's then not clear which location is reported. --- Also, errors in type signatures are not caught. --- However, usually, the problematic cases are syntax errors, and these are --- prevented by parsing the definitions first. - -INCLUDE "ExecutionPlan.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "HsToken.ag" - -imports -{ -import ExecutionPlan -import Pretty -import PPUtil -import Options -import Data.Monoid(mappend,mempty) -import Data.Maybe -import Data.Graph -import Debug.Trace -import System.IO -import System.Directory -import System.FilePath -import UU.Scanner.Position - -import TokenDef -import HsToken -import ErrorMessages - -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Sequence(Seq) -import qualified Data.Sequence as Seq -import Data.Foldable(toList) -} - -ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild - [ mainFile, mainName : String | | ] - -------------------------------------------------------------------------------- --- Options -------------------------------------------------------------------------------- -ATTR ExecutionPlan - ENonterminals ENonterminal - EProductions EProduction - ERules ERule - EChildren EChild - Expression - HsToken HsTokens HsTokensRoot - Pattern Patterns - Visits Visit - VisitSteps VisitStep [ options : {Options} | | ] -ATTR EProductions EProduction [ rename : {Bool} | | ] - -SEM ENonterminal | ENonterminal - prods.rename = rename @lhs.options - -------------------------------------------------------------------------------- --- Context info (nonterminal ident, constructor ident, nonterm params, etc.) -------------------------------------------------------------------------------- - -ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ] -SEM ENonterminal | ENonterminal - prods.nt = @nt - -ATTR EChildren EChild ERules ERule Visits Visit [ con : ConstructorIdent | | ] - -SEM EProduction | EProduction children.con = @con - rules.con = @con - visits.con = @con - -ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ] -SEM ENonterminal | ENonterminal - prods.params = @params - -------------------------------------------------------------------------------- --- output attributes: we make a distinction between data declarations --- and code -------------------------------------------------------------------------------- -ATTR ExecutionPlan [ | | datas, code, modules : {PP_Doc} ] - -SEM ExecutionPlan | ExecutionPlan - lhs.code = @nonts.code >-< @loc.wrappersExtra - lhs.datas = @nonts.datas >-< @loc.commonExtra - -ATTR ENonterminal ENonterminals - [ wrappers : {Set NontermIdent} | | datas,code,modules USE {>-<} {empty} : {PP_Doc} ] - -SEM ExecutionPlan | ExecutionPlan - nonts.wrappers = @wrappers - -SEM ENonterminal | ENonterminal - lhs.datas = ( text "" - >-< "(* *** " ++ getName @nt ++ " *** [data] *)") - >-< (if dataTypes @lhs.options - then pp "(* data *)" - >-< @loc.datatypeNt - >-< @loc.datatypeProds - >-< "" - else empty) - >-< (if @loc.hasWrapper - then pp "(* wrapper *)" - >-< @loc.wr_inh - >-< @loc.wr_syn - >-< "" - else empty) - >-< (if semfuns @lhs.options - then pp "(* semantic domain *)" - >-< @loc.t_init - >-< @loc.t_states - >-< @loc.c_states - >-< @prods.t_visits - >-< "" - else empty) - - lhs.code = ( text "" - >-< "(* *** " ++ getName @nt ++ " *** [code] *)") - >-< (if dataTypes @lhs.options - then pp "(* constructor functions *)" - >-< @loc.datatypeCon - else empty) - >-< (if @loc.hasWrapper - then pp "(* wrapper *)" - >-< @loc.wrapper - >-< "" - else empty) - >-< (if folds @lhs.options - then "(* cata *)" - >-< @loc.sem_nt - >-< "" - else empty) - >-< (if semfuns @lhs.options - then "(* semantic domain *)" - >-< @prods.sem_prod - >-< "" - else empty) - - -- note: we assume that these module declarations are not recursive, and - -- that their parameters do not depends on types generated by AG in the - -- same file. - lhs.modules = @loc.moduleDecl - - loc.hasWrapper = @nt `Set.member` @lhs.wrappers - -------------------------------------------------------------------------------- --- Nonterminal datatype -------------------------------------------------------------------------------- -ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} | | ] - -SEM ExecutionPlan | ExecutionPlan - nonts.typeSyns = @typeSyns - -{ -ppRecordTp :: PP a => [a] -> PP_Doc -ppRecordTp es - | null es = text "unit" - | otherwise = pp_block "{" "}" "; " (map pp es) - -ppRecordVal :: PP a => [a] -> PP_Doc -ppRecordVal es - | null es = text "()" - | otherwise = pp_block "{" "}" "; " (map pp es) - -ppFieldsVal :: Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc -ppFieldsVal record fields - | null fields = text "()" - | record = ppRecordVal [ r >#< "=" >#< x | (r,x,_,_) <- fields ] - | otherwise = pp_block "(" ")" "," [ x | (_,x,_,_) <- fields ] - -ppFieldsType :: Bool -> Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc -ppFieldsType record defor fields - | null fields = text "unit" - | record = ppRecordTp [ r >#< ":" >#< (if defor then d else f) | (r,_,d,f) <- fields ] - | otherwise = pp_block "(" ")" "*" [ if defor then d else f | (_,_,d,f) <- fields ] -} - - --- for each nonterminal, the following data types in ocmal: --- * data type for the nonterminal, with a constructor for --- each production. The constructor takes a single field --- with the type explained below. --- * for each production, a record type comprising the --- children of the production. --- --- * class contexts are ignored --- * at most one type variable --- --- aliasses: lists, tuples --- *** think about maps, sets, etc. Perhaps the name of --- the alias should become a local module name. --- - -SEM ENonterminal | ENonterminal - loc.t_params = ppTypeParams @params - loc.aliasPre = "and" >#< @loc.t_params >#< @nt >#< "=" - loc.aliasMod = @loc.aliasPre >#< modName @nt >|< ".t" - loc.datatypeNt - = case lookup @nt @lhs.typeSyns of - -- generate special code for certain type aliasses - Just (List t) -> @loc.aliasPre >#< ppTp t >#< "list" - Just (Maybe t) -> @loc.aliasPre >#< ppTp t >#< "option" - Just (Tuple ts) -> @loc.aliasPre >#< (pp_block "(" ")" " * " $ map (ppTp . snd) ts) - - Just (Map k v) -> @loc.aliasMod - Just (IntMap t) -> @loc.aliasMod - Just (OrdSet t) -> @loc.aliasMod - Just IntSet -> @loc.aliasMod - - -- use the constructor-based data-type generation for all other types - _ -> "and" >#< @loc.t_params >#< @nt >#< "=" - >-< ( if null @prods.datatype - then pp "unit" - else indent 2 $ vlist @prods.datatype_call - ) - - loc.datatypeCon - = case lookup @nt @lhs.typeSyns of - Just _ -> empty -- no constructor funs for type aliasses - Nothing -> vlist @prods.datatype_con - - loc.moduleDecl - = let ppModule :: PP a => a -> PP_Doc - ppModule expr = "module" >#< modName @nt >#< "=" - in case lookup @nt @lhs.typeSyns of - Just (Map k _) -> ppModule ("Map.Make" >#< pp_parens (ppTp k)) - Just (IntMap _) -> ppModule ("Map.Make ()") - Just (OrdSet t) -> ppModule ("Set.Make" >#< pp_parens (ppTp t)) - Just IntSet -> ppModule ("Set.Make (struct type t = int let compare = Pervasives.compare end)") - _ -> empty - - loc.datatypeProds = vlist @prods.datatype - -ATTR EProduction [ | | datatype, datatype_call, datatype_con : {PP_Doc} ] -ATTR EProductions [ | | datatype, datatype_call, datatype_con USE {:} {[]} : {[PP_Doc]} ] - -SEM EProduction | EProduction - loc.o_records = dataRecords @lhs.options - loc.t_params = ppTypeParams @lhs.params - loc.t_c_params = ppTypeParams (cont_tvar : map pp @params) - loc.conname = conname @lhs.rename @lhs.nt @con - loc.recname = pp "fields_" >|< @loc.conname - lhs.datatype = "and" >#< @loc.t_params >#< @loc.recname >#< "=" - >#< ppFieldsType @loc.o_records False @children.sigs - lhs.datatype_call = pp "|" >#< @loc.conname >#< "of" >#< pp_parens (@loc.t_params >#< @loc.recname) - lhs.datatype_con - = let funNm = @lhs.nt >|< "_" >|< @con - decl = "and" >#< ppFunDecl @loc.o_sigs funNm params (@loc.t_params >#< @lhs.nt) body - params = [ (x, t) | (_,x,_,t) <- @children.sigs ] - body = @loc.conname >#< ppFieldsVal @loc.o_records @children.sigs - in decl - -ATTR EChild EChildren [ | | sigs USE {++} {[]} : {[(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]} ] - -SEM EChild - | EChild ETerm - loc.tpDocFor = ppTp $ removeDeforested @tp - loc.tpDocDefor = ppTp $ forceDeforested @tp - loc.fieldNm = text $ recordFieldname @lhs.nt @lhs.con @name - loc.childNm = text (fieldname @name) - loc.field = (@loc.fieldNm, @loc.childNm, @loc.tpDocDefor, @loc.tpDocFor) - | EChild lhs.sigs = case @kind of - ChildAttr -> [] -- higher order attributes are not part of the data type - _ -> [@loc.field] - | ETerm lhs.sigs = [@loc.field] - -{ -ppTp :: Type -> PP_Doc -ppTp tp = case tp of - Haskell t -> pp t -- ocaml type - NT nt tps deforested - | nt == _SELF -> pp "?SELF?" - | null tps -> ppNontTp nt deforested - | otherwise -> pp_parens (ppSpaced (map pp_parens tps) >#< ppNontTp nt deforested) - Self -> pp "?SELF?" - -ppNontTp :: NontermIdent -> Bool -> PP_Doc -ppNontTp nt True = pp "t_" >|< pp nt -ppNontTp nt False = pp nt - --- multiple type parameters go into a tuple -ppTypeParams :: PP a => [a] -> PP_Doc -ppTypeParams [] = empty -ppTypeParams [x] = pp x -ppTypeParams xs = pp_block "(" ")" "," (map pp xs) -} - -------------------------------------------------------------------------------- --- Nonterminal semantic function -------------------------------------------------------------------------------- -SEM ENonterminal | ENonterminal - loc.fsemname = \x -> prefix @lhs.options ++ show x - loc.semname = @loc.fsemname @nt - loc.frecarg = \t x -> case t of - NT nt _ _ -> pp_parens (@fsemname nt >#< x) - _ -> x - - loc.sem_param_tp = @loc.t_params >#< @nt - loc.sem_res_tp = @loc.t_params >#< @loc.t_type - loc.sem_tp = @loc.sem_param_tp >#< "->" >#< @loc.sem_res_tp - - loc.o_sigs = typeSigs @lhs.options - loc.sem_nt_body = "match arg with" >-< (indent 2 $ @prods.sem_nt) - loc.sem_nt = let genSem :: PP a => a -> PP_Doc -> PP_Doc - genSem nm body = "and" >#< ppFunDecl @loc.o_sigs (pp @loc.semname) [(pp nm, @loc.sem_param_tp)] @loc.sem_res_tp body - genAlias alts = genSem (pp "arg") (pp "match arg with" >-< (indent 2 $ vlist $ map (pp "|" >#<) alts)) - genMap v = let body = modName @nt >|< ".fold" >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" >#< els - els = case v of - NT nt _ _ -> pp_parens (modName @nt >|< ".map" >#< @loc.fsemname nt >#< "m") - _ -> pp "m" - in genSem "m" body - genSet mbNt = let body = "List.fold_right" >#< @loc.semname >|< "_Entry" >#< - els (pp_parens (modName @nt >|< ".elements" >#< "s")) >#< @loc.semname >|< "_Nil" - els r = maybe r (\nt -> pp_parens ("List.map" >#< @loc.fsemname nt >#< r)) mbNt - in genSem "s" body - in case lookup @nt @lhs.typeSyns of - -- generate special code for some aliasses - Just (List t) -> let body = "List.fold_right" >#< @loc.semname >|< "_Cons" >#< els >#< @loc.semname >|< "_Nil" - els = case t of - NT nt _ _ -> pp_parens ("List.map" >#< @loc.fsemname nt >#< "list") - _ -> pp "list" - in genSem "list" body - Just (Tuple ts) -> let pat = pp_parens (ppCommas $ map fst ts) - body = @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @loc.frecarg (snd t) (pp $ fst t)) ts) - in genSem pat body - Just (Map _ v) -> genMap v - Just (IntMap v) -> genMap v - Just (Maybe t) -> genAlias - [ "None" >#< "->" >#< "=" >#< @loc.semname >|< "_Nothing" - , "Some" >#< "just" >#< "->" >#< @loc.semname >|< "_Just" >#< @frecarg t (pp "just") - ] - Just (OrdSet t) -> genSet $ case t of - NT nt _ _ -> Just nt - _ -> Nothing - Just (IntSet) -> genSet Nothing - - -- structural fold for the remaining cases - _ -> genSem "arg" @loc.sem_nt_body - -{ --- convention for nonterminals to module names -modName :: NontermIdent -> PP_Doc -modName nt = pp "M_" >|< pp nt - -ppFunDecl :: Bool -> PP_Doc -> [(PP_Doc,PP_Doc)] -> PP_Doc -> PP_Doc -> PP_Doc -ppFunDecl gensigs nm args resSig expr = body where - body = nm >#< ppSpaced (map arg args) >#< ppRes >#< "=" - >-< indent 2 expr - arg (arg,tp) = ppArg gensigs arg tp - ppRes - | gensigs = ":" >#< resSig - | otherwise = empty - -ppArg :: Bool -> PP_Doc -> PP_Doc -> PP_Doc -ppArg gensigs arg tp - | gensigs = pp_parens (arg >#< ":" >#< tp) - | otherwise = arg - -} - --- The number of productions -ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ] -SEM EProduction | EProduction lhs.count = {1} - --- The per-production match-expr cases for the sem_NT function -ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ] -SEM EProduction | EProduction - lhs.sem_nt = "|" >#< conname @lhs.rename @lhs.nt @con >#< ppFieldsVal @loc.o_records @children.sigs >#< "->" >#< - prefix @lhs.options >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw - -ATTR EChild [ | | argnamesw : { PP_Doc } ] -ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ] - -SEM EChild - | EChild lhs.argnamesw = case @kind of - ChildSyntax -> "(" >#< prefix @lhs.options >|< @loc.nt >#< @name >|< "_" >#< ")" - ChildAttr -> empty -- no sem-case for a higher-order child - ChildReplace tp -> "(" >#< prefix @lhs.options >|< extractNonterminal tp >#< @name >|< "_" >#< ")" - | ETerm lhs.argnamesw = text $ fieldname @name - -------------------------------------------------------------------------------- --- Types of attributes -------------------------------------------------------------------------------- -ATTR ExecutionPlan - ENonterminals - ENonterminal [ inhmap : {Map NontermIdent Attributes} - synmap : {Map NontermIdent Attributes} | | ] - -ATTR EProductions EProduction - ERules ERule - Patterns Pattern - Visits - Visit [ inhmap : {Attributes} - synmap : {Attributes} - allInhmap : {Map NontermIdent Attributes} - allSynmap : {Map NontermIdent Attributes} | | ] - -SEM ENonterminal - | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap - (Just prods.synmap) = Map.lookup @nt @lhs.synmap - prods.allInhmap = @lhs.inhmap - prods.allSynmap = @lhs.synmap - -------------------------------------------------------------------------------- --- State datatypes -------------------------------------------------------------------------------- -{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)} - -ATTR Visit [ | | allvisits : { VisitStateState }] -ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}] -ATTR EProduction - EProductions [ | | allvisits: {[VisitStateState]}] - -SEM Visit - | Visit lhs.allvisits = (@ident, @from, @to) - -SEM EProductions - | Cons lhs.allvisits = @hd.allvisits -- just pick the first production - | Nil lhs.allvisits = error "Every nonterminal should have at least 1 production" - --- type of tree in a given state s -SEM ENonterminal | ENonterminal - loc.allstates = orderStates @initial @prods.allvisits - loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits - loc.t_type = type_nt_sem_top @nt - loc.t_c_params = ppTypeParams (cont_tvar : map pp @params) - - -- the initial "s" type: contains the "attach" function that delivers the initial st - loc.t_init = "and" >#< @loc.t_params >#< @loc.t_type >#< "=" >#< pp_braces ( nm_attach @nt >#< ":" >#< "unit" >#< "->" >#< @loc.t_params >#< type_nt_sem @nt @initial) - - -- the "s" type in a given state: contains the invoke function to go to a next state - loc.t_states = vlist $ map (\st -> - let s_st = type_nt_state @nt st - t_st = type_nt_sem @nt st - c_st = type_caller @nt st - nextVisits = Map.findWithDefault ManyVis st @nextVisits - decl = "and" >#< @loc.t_params >#< t_st >#< "=" - in case nextVisits of - NoneVis -> decl >#< "unit" -- final state: no more subsequent visits - _ -> decl >#< ppRecordVal [ nm_invoke @nt st >#< ":" >#< cont_tvar >#< "." >#< @loc.t_c_params >#< c_st >#< "->" >#< cont_tvar ] - ) @loc.allstates - -{ --- --- conventions --- - --- type of the state of a node: a closure containing the children states and attributes, --- with code of type 'type_nt_sem' that represents the subsequent visits to successor states. -type_nt_state nt st = "s_" >|< nt >|< "_" >|< st - --- type of a visit to a node (the initial, and when in a given state) --- an instance of this type is called the "semantics" -type_nt_sem_top nt = "t_" >|< nt -type_nt_sem nt st = type_nt_sem_top nt >|< "_s" >|< st - --- type of a caller (contains visit selection + inputs + continuation) -type_caller nt st = "c_" >|< nt >|< "_s" >|< st - --- names of records -nm_attach nt = "attach_">|< nt -nm_invoke nt st = "inv_" >|< nt >|< "_s" >|< st - --- name of the type variable representing the result type of the continuation -cont_tvar = text "'cont__" - - --- order states in reverse topological order so that successor states are --- earlier in the resulting list. -orderStates :: StateIdentifier -> [VisitStateState] -> [StateIdentifier] -orderStates initial edges = res where - source = Map.singleton initial Set.empty -- ensures that the initial state is in graph even when there are no edges - targets = [ Map.singleton t Set.empty | (_,_,t) <- edges ] - deps = [ Map.singleton f (Set.singleton t) | (_,f,t) <- edges ] - - mp = Map.unionsWith Set.union (source : (targets ++ deps)) - es = [ (f,f,Set.toList ts) | (f,ts) <- Map.toList mp ] - cps = stronglyConnComp es - res = flattenSCCs cps -} - --- type of a caller that selects a visit v from state s of the child, and --- provides a continuation of the caller after the visit to the child -SEM ENonterminal | ENonterminal - loc.c_states = vlist $ map (\st -> - let nt_st = type_nt_state @nt st - c_st = type_caller @nt st - outg = filter (\(_,f,_) -> f == st) @prods.allvisits - nextVisits = Map.findWithDefault ManyVis st @nextVisits - declHead = "and" >#< @loc.t_c_params >#< c_st >#< "=" - visitcons = vlist $ map (\(v,_,_) -> - "|" >#< con_visit @nt v >#< "of" >#< @loc.t_c_params >#< type_caller_visit @nt v - ) outg - in case nextVisits of -- slight optimization for when there is only one visit - NoneVis -> empty -- st is final state, no subsequent visits, thus no more caller info - OneVis v -> declHead >#< @loc.t_c_params >#< type_caller_visit @nt v - ManyVis -> declHead >-< indent 3 visitcons - ) @loc.allstates - -{ -type_caller_visit nt v = "c_" >|< nt >|< "_v" >|< v -con_visit nt v = "C_" >|< nt >|< "_v" >|< v - --- field names -nm_inh nt v = "inh_" >|< nt >|< "_v" >|< v -nm_cont nt v = "cont_" >|< nt >|< "_v" >|< v -} - --- type t_visit of a call to a visit v (inputs to the visit + continuation of the parents that gets the output + new state of the child) -ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ] - -SEM EProductions | Cons - lhs.t_visits = @hd.t_visits - -- just pick the first production (these results are the same for all of them) - -- todo: that means we should actually represent visit declarations in the AST... - -SEM Visit | Visit - loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident - loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident - loc.nameNextState = type_nt_sem @lhs.nt @to - loc.nameCaller_visit = type_caller_visit @lhs.nt @ident - - loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state? - - loc.t_params = ppTypeParams @lhs.params - loc.t_c_params = ppTypeParams (cont_tvar : map pp @lhs.params) - - -- data type decls for the t_visit type - -- we generate a type for the caller of a visit, the arguments of the visit and the result of the visit - lhs.t_visits = "and" >#< @loc.t_c_params >#< @loc.nameCaller_visit >#< "=" >#< ppRecordTp - [ nm_inh @lhs.nt @ident >#< ":" >#< @loc.t_params >#< conNmTVisitIn @lhs.nt @ident - , nm_cont @lhs.nt @ident >#< ":" >#< @loc.t_params >#< conNmTVisitOut @lhs.nt @ident >#< "->" >#< cont_tvar - ] - >-< "and" >#< @loc.t_params >#< @loc.nameTIn_visit >#< "=" >#< ppRecordTp @loc.inhpart - >-< "and" >#< @loc.t_params >#< @loc.nameTOut_visit >#< "=" >#< ppRecordTp (@loc.synpart ++ @loc.contpart) - - loc.contpart = case @loc.nextVisitInfo of - NoneVis -> [] -- don't provide a continuation at all - _ -> [ nm_outarg_cont @lhs.nt @ident >#< ":" >#< @loc.t_params >#< @loc.nameNextState ] -- normal route: select the next semantics - - loc.inhpart = @loc.ppTypeList nm_inarg @inh @lhs.inhmap - loc.synpart = @loc.ppTypeList nm_outarg @syn @lhs.synmap - loc.ppTypeList = \f s m -> map (\i -> case Map.lookup i m of - Just tp -> f i @lhs.nt @ident >#< ":" >#< ppTp tp ) $ Set.toList s - -{ --- more naming conventions -nm_inarg nm nt v = "i_" >|< nm >|< "_" >|< nt >|< "_v" >|< v -nm_outarg nm nt v = "o_" >|< nm >|< "_" >|< nt >|< "_v" >|< v -nm_outarg_cont = nm_outarg "_cont" - -conNmTVisit nt vId = "t_" >|< nt >|< "_v" >|< vId -conNmTVisitIn nt vId = "t_" >|< nt >|< "_vIn" >|< vId -conNmTVisitOut nt vId = "t_" >|< nt >|< "_vOut" >|< vId - --- todo: remove ppMonadType -ppMonadType :: Options -> PP_Doc -ppMonadType opts - | parallelInvoke opts = text "IO" - | otherwise = text "Identity" -} - -------------------------------------------------------------------------------- --- Inh and Syn wrappers -------------------------------------------------------------------------------- -SEM ENonterminal | ENonterminal - loc.wr_inh = @loc.genwrap "inh" @loc.wr_inhs1 -- todo: is perhaps a mistake in 2hs - loc.wr_syn = @loc.genwrap "syn" @loc.wr_syns - loc.genwrap = \nm attrs -> - "and" >#< @loc.t_params >#< nm >|< "_" >|< @nt >#< "=" >#< ppRecordTp - [ i >|< "_" >|< nm >|< "_" >|< @nt >#< ":" >#< ppTp t | (i,t) <- attrs ] - - loc.inhAttrs = fromJust $ Map.lookup @nt @lhs.inhmap - loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.inhAttrs - loc.wr_inhs1 = Map.toList @loc.inhAttrs - loc.wr_filter = if kennedyWarren @lhs.options && lateHigherOrderBinding @lhs.options - then Map.delete idLateBindingAttr - else id - loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap - - loc.wrapname = text ("wrap_" ++ show @nt) - loc.inhname = text ("inh_" ++ show @nt) - loc.synname = text ("syn_" ++ show @nt) - loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits - - loc.wrapArgSemTp = @loc.t_params >#< @loc.t_type - loc.wrapArgInhTp = @loc.t_params >#< @loc.inhname - loc.wrapArgPats = ppRecordVal [ i >|< "_inh_" >|< @nt >#< "=" >#< lhsname @lhs.options True i | (i,_) <- @loc.wr_inhs1 ] - loc.wrapResTp = @loc.t_params >#< @loc.synname - loc.wrapper = "and" >#< ppFunDecl @loc.o_sigs @loc.wrapname [(pp "act", @loc.wrapArgSemTp), (@loc.wrapArgPats, @loc.wrapArgInhTp)] @loc.wrapResTp @loc.wrapperPreamble - loc.wrapperPreamble - = ( if lateHigherOrderBinding @lhs.options - then "let" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName >#< "in" - else empty - ) -- initial attribute for late binding - >-< @loc.wrapperBody - loc.wrapperBody - = case @initialv of - [] -> text "{ }" -- case where there are no inherited or synthesized attributes - (initv:_) -> -- TODO: take care of multiple visits - let attach = "let" >#< "sem" >#< "=" >#< "act." >|< nm_attach @nt >#< "()" >#< "in" -- run attach code - - -- result transformer to wrapper output record - pat = ppRecordVal [ nm_outarg i @nt initv >#< "=" >#< lhsname @lhs.options False i | (i,_) <- @loc.wr_syns ] - bld = ppRecordVal [ i >|< "_syn_" >|< @nt >#< "=" >#< lhsname @lhs.options False i | (i,_) <- @loc.wr_syns ] - res = "let res = function" >#< pat >#< "->" >#< bld >#< "in" - - -- input to the visit (inh attrs + continuation) - inps = "let" >#< "inps" >#< "=" >#< ppRecordVal [ nm_inarg i @nt initv >#< "=" >#< lhsname @lhs.options True i | (i,_) <- @loc.wr_inhs ] >#< "in" - arg = "let" >#< "arg" >#< "=" >#< argcon >#< argrec >#< "in" - argcon = case @loc.firstVisitInfo of - ManyVis -> con_visit @nt initv - _ -> empty - argrec = ppRecordVal - [ nm_inh @nt initv >#< "=" >#< "inps" - , nm_cont @nt initv >#< "=" >#< "res" - ] - invoke = "sem." >|< nm_invoke @nt @initial >#< "arg" -- invoke the visit - in attach >-< res >-< inps >-< arg >-< invoke - -------------------------------------------------------------------------------- --- Collection of NT / Production sem funs references -------------------------------------------------------------------------------- - -ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ] -SEM ENonterminal | ENonterminal - lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs - lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps - loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname - loc.semFunBndTp = @loc.semFunBndNm >#< ":" >#< @loc.sem_tp - loc.semFunBndNm = lateSemNtLabel @nt - -SEM EProduction | EProduction - lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef - lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp - loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname - loc.semFunBndTp = @loc.semFunBndNm >#< ":" >#< @loc.sem_tp - loc.semFunBndNm = lateSemConLabel @lhs.nt @con - --- Generate a dictionary that contains the semantics of all semantic functions -SEM ExecutionPlan | ExecutionPlan - loc.wrappersExtra = if lateHigherOrderBinding @lhs.options - then @loc.lateSemBndDef - else empty - loc.commonExtra = if lateHigherOrderBinding @lhs.options - then @loc.lateSemBndTp - else empty - loc.lateSemBndTp = "and" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< ppRecordTp (toList @nonts.semFunBndTps) - loc.lateSemBndDef = "and" >#< lateBindingFieldNm @lhs.mainName >#< ":" >#< lateBindingTypeNm @lhs.mainName >#< "=" - >-< (indent 2 $ ppRecordVal $ toList @nonts.semFunBndDefs) - -------------------------------------------------------------------------------- --- Production semantic functions -------------------------------------------------------------------------------- -ATTR EProduction [ | | sem_prod : {PP_Doc} ] -ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ] - -ATTR EProduction EProductions [ initial : {StateIdentifier} - allstates : {[StateIdentifier]} | | ] -SEM ENonterminal | ENonterminal - prods.initial = @initial - prods.allstates = @loc.allstates - -SEM EProduction | EProduction - loc.o_sigs = typeSigs @lhs.options - loc.t_type = type_nt_sem_top @lhs.nt - loc.semname = prefix @lhs.options >|< @lhs.nt >|< "_" >|< @con - loc.sem_res_tp = @loc.t_params >#< @loc.t_type - loc.sem_tp = pp_block "" "" "->" [ d | (_,_,d,_) <- @children.sigs ] >#< "->" >#< @loc.sem_res_tp - - loc.initializer - = -- some actions, performed upon attaching a child, can - -- be specified here in the form of a let-expression. - -- The resulting bindings of these actions are - -- in scope of the rules of the production - empty -- nothing for now - - loc.sem_prod = "and" >#< ppFunDecl @loc.o_sigs @loc.semname [ (x,d) | (_,x,d,_) <- @children.sigs ] @loc.sem_res_tp @loc.prod_body - loc.prod_body - = @loc.initializer - >-< "{" >#< nm_attach @lhs.nt >#< "=" >#< "function () ->" - >-< indent 2 - ( "(* rules of production" >#< @con >#< "*)" - >-< @rules.sem_rules - >-< "(* states of production" >#< @con >#< "*)" - >-< vlist @loc.statefuns - >-< nm_st @lhs.initial - ) - >#< "}" - - -- the semantic function of a production: defines a series of states and - -- their transitions. Two sorts of functions are important: - -- k-functions: inspect the caller_type to find out which visit the - -- caller wants and then dispatches that visit and continuation. - -- v-functions: the actual code of the visit. - loc.statefuns = map @loc.genstfn @lhs.allstates - loc.genstfn - = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits - stNm = nm_st st - - -- note about the initial state: the initial state should be the only - -- state-binding that is not a function. It is non-recursive, its definition does - -- not involve side effect, and its not needed - -- anywhere except to be delivered as initial result. - stDef body = "let" >#< stNm >#< (if st == @lhs.initial then empty else @loc.stargs st) >#< "=" - >-< indent 2 body >#< "in" - - in case nextVisitInfo of - NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced - -- thus generating it is not needed (and omitting it may catch some small mistakes). - if st == @lhs.initial - then stDef (pp "unit") -- empty state - else empty -- no state generated - _ -> stDef $ mklets (@loc.stvs st ++ @loc.stks st) $ ppRecordVal - [ nm_invoke @lhs.nt st >#< "=" >#< nm_k st ] - - loc.stargs - = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap in ppSpaced - [ case mbAttr of - Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> - case Map.lookup nm @loc.localAttrTypes of - Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp) - Nothing -> pp strNm - Just attr | not (noPerStateTypeSigs @lhs.options) -> - case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of - Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc) - Nothing -> pp strNm - _ -> pp strNm - | (strNm, mbAttr) <- Map.assocs attrs - ] >#< dummyPat @lhs.options (Map.null attrs) - - -- produces the "k" function that inspect the caller argument to dispatch a visit - loc.stvisits = \st -> filter (\(_,f,_) -> f == st) @visits.allvisits - loc.stks - = \st -> let stvisits = @loc.stvisits st - def = ppFunDecl False {- @loc.o_sigs -} (pp $ nm_k st) - [(pp "arg", @loc.t_c_params >#< type_caller @lhs.nt st)] (pp cont_tvar) body - - nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits - body = case nextVisitInfo of - NoneVis -> text "?no next visit?" - OneVis v -> dispatch "arg" v - ManyVis -> let alt (v,_,_) = "|" >#< con_visit @lhs.nt v >#< "chosen" >#< "->" >-< indent 2 (dispatch "chosen" v) - in "match arg with" >-< (indent 2 $ vlist $ map alt stvisits) - - dispatch nm v = "let" >#< ppRecordVal - [ nm_inh @lhs.nt v >#< "=" >#< "inp" - , nm_cont @lhs.nt v >#< "=" >#< "cont" ] - >#< "=" >#< pp nm - >-< "in" >#< "cont" >#< pp_parens (nm_visit v >#< "inp") -- call cont with res of visit - - in if null stvisits - then [] - else [ "(* k-function for production" >#< @con >#< " *)" >-< def ] - - loc.stvs = \st -> [ppf | (f,ppf) <- @visits.sem_visit, f == st] - visits.mrules = @rules.mrules - -{ -nm_visit v = "__v" >|< v -nm_k st = "__k" >|< st -nm_st st = "__st" >|< st - -mklets :: (PP b, PP c) => [b] -> c -> PP_Doc -mklets defs body = res where - ppLet def = "let" >#< def >#< "in" - res = vlist (map ppLet defs) >-< body -} - -------------------------------------------------------------------------------- --- Visit semantic functions -------------------------------------------------------------------------------- -ATTR Visit [ | | sem_visit : { (StateIdentifier,PP_Doc) } ] -ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,PP_Doc)] } ] - -SEM Visit | Visit - loc.o_sigs = typeSigs @lhs.options - lhs.sem_visit = ( @from - , let resTp = @loc.t_params >#< @loc.nameTOut_visit - argTp = @loc.t_params >#< @loc.nameTIn_visit - argMatch = ppRecordVal [ nm_inarg i @lhs.nt @ident >#< "=" >#< lhsname @lhs.options True i | i <- Set.toList @inh ] - in ppFunDecl @loc.o_sigs (nm_visit @ident) [(argMatch, argTp)] resTp @steps.sem_steps - ) - - steps.follow = @loc.nextStBuild >-< @loc.resultval - - loc.nextArgsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap - loc.nextArgs = ppSpaced $ Map.keys $ @loc.nextArgsMp - loc.nextStExp = nm_st @to >#< @loc.nextArgs >#< dummyArg @lhs.options (Map.null @loc.nextArgsMp) - - loc.resultval = ppRecordVal - ( [ nm_outarg i @lhs.nt @ident >#< "=" >#< lhsname @lhs.options False i | i <- Set.toList @syn ] - ++ [ @loc.nextStRefExp ]) - - (loc.nextStBuild, loc.nextStRefExp) - = case @loc.nextVisitInfo of - NoneVis -> (empty, empty) - _ -> ( "let" >#< nextStName >#< "=" >#< @loc.nextStExp >#< "in" - , nm_outarg_cont @lhs.nt @ident >#< "=" >#< nextStName) - -{ -resultValName :: String -resultValName = "__result_" - -nextStName :: String -nextStName = "__st_" -} - --- Propagate the visit kind to the steps -ATTR VisitStep VisitSteps [ kind : VisitKind | | ] -SEM Visit | Visit steps.kind = @kind - --- the steps in this group should be executed in a pure fashion -SEM VisitStep | PureGroup - steps.kind = VisitPure @ordered - --- follow: the code of steps that follows after the VisitStep -ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> Either Error PP_Doc)} | | ] -ATTR VisitStep VisitSteps [ follow : PP_Doc | | sem_steps USE {>-<} {empty} : PP_Doc ] - --- continuation flow (passing the right steps as left follow steps) -SEM VisitSteps - | Cons hd.follow = @tl.sem_steps - lhs.sem_steps = @hd.sem_steps - | Nil lhs.sem_steps = @lhs.follow - -SEM VisitStep - | Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules - (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind of - Left e -> (Seq.singleton e, empty) - Right stmt -> (Seq.empty, stmt) - lhs.sem_steps = @loc.sem_steps >-< @lhs.follow - | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros - (lhs.errors,loc.sem_steps,lhs.defs,lhs.uses) - = case @loc.attachItf @lhs.kind of - Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) - Right (code, defs, uses) -> (Seq.empty, code, defs, uses) - lhs.sem_steps = @loc.sem_steps >-< @lhs.follow - | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit - loc.childType = Map.findWithDefault (error ("type of child " ++ show @child ++ " is not in the childTypes map! " ++ show @lhs.childTypes)) @child @lhs.childTypes - (lhs.errors, lhs.sem_steps) = case @loc.visitItf @child @loc.childType @lhs.kind @lhs.follow of - Left e -> (Seq.singleton e, empty) - Right steps -> (Seq.empty, steps) - | Sim -- simply propagates - | PureGroup -- simply propagates - --- --- Some properties of VisitStep(s) --- - --- Number of steps in a 'Sim' block -ATTR VisitSteps [ | | size : Int ] -SEM VisitSteps - | Nil lhs.size = 0 - | Cons lhs.size = 1 + @tl.size - --- Number the steps in a 'Sim' block -ATTR VisitSteps VisitStep [ | index : Int | ] -SEM VisitSteps | Cons - hd.index = @lhs.index -- copy rule - tl.index = 1 + @lhs.index - lhs.index = @tl.index -- copy rule -SEM Visit | Visit steps.index = 0 -SEM VisitStep | Sim steps.index = 0 - lhs.index = @lhs.index -- needed for if we ever allow nested Sims - --- Biggest number of steps in previous blocks that used parallel invocation --- This number - 1 (minimum 0) is the number of references for parallel invocation created -ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ] -SEM Visit | Visit steps.prevMaxSimRefs = 0 -SEM VisitStep | Sim - lhs.prevMaxSimRefs = if @loc.useParallel - then @lhs.prevMaxSimRefs `max` (@steps.index - 1) -- possibly new references made - else @lhs.prevMaxSimRefs -- no references created - --- Is this the last step? -ATTR VisitSteps VisitStep [ | | isLast : Bool ] -ATTR VisitStep [ isLast : Bool | | ] -SEM VisitSteps - | Nil lhs.isLast = True - | Cons lhs.isLast = False - hd.isLast = @tl.isLast - --- Use parallel invocation: only when option enabled and there is more than one visit to a child --- Todo: implement a parallel evaluator -SEM VisitSteps VisitStep [ useParallel : Bool | | ] -SEM Visit | Visit steps.useParallel = False -SEM VisitStep | Sim loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1 - --- Child introduction -ATTR EChild EChildren - [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ] - -ATTR Visits Visit VisitSteps VisitStep - [ childintros : {Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ] - -SEM EProduction | EProduction - visits.childintros = @children.childintros - -SEM EChild - | ETerm lhs.childintros = Map.singleton @name (\_ -> Right (empty, Set.empty, Map.empty)) - | EChild lhs.childintros = Map.singleton @name @loc.introcode - loc.isDefor = case @tp of - NT _ _ defor -> defor - _ -> False - loc.valcode = case @kind of - ChildSyntax -> @name >|< "_" - ChildAttr -> -- decide if we need to invoke the sem-function under the hood - let head | not @loc.isDefor = if lateHigherOrderBinding @lhs.options - then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr - else prefix @lhs.options >|< @loc.nt - | otherwise = empty -- no need to intro a terminal - in pp_parens (head >#< instname @name) - ChildReplace _ -> -- the higher-order attribute is actually a function that transforms - -- the semantics of the child (always deforested) - pp_parens (instname @name >#< @name >|< "_") - loc.aroundcode = if @hasAround - then locname @lhs.options @name >|< "_around" - else empty - loc.introcode = \kind -> let pat = text $ stname @name @loc.initSt - attach = pp_parens (@loc.aroundcode >#< @loc.valcode) >|< "." >|< nm_attach @loc.nt >#< "()" - decl = pat >#< "=" >#< attach - in if compatibleAttach kind @loc.nt @lhs.options - then Right ( "let" >#< decl >#< "in" - , Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro - , case @kind of -- variables used by the child introduction - ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr - ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options) - then id -- the sem dictionary attr is not used - else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) - ) $ - ( if @hasAround - then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing - else id - ) $ Map.empty - ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function - ChildSyntax -> Map.empty - ) - else Left $ IncompatibleAttachKind @name kind - loc.nt = extractNonterminal @tp - -{ -stname :: Identifier -> Int -> String -stname child st = "_" ++ getName child ++ "X" ++ show st - --- should actually return some conversion info -compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool -compatibleAttach _ _ _ = True -} - --- rules -ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc} - mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> Either Error PP_Doc)} ] - -SEM ERule | ERule - lhs.sem_rules = if @loc.used == 0 - then empty - else @loc.rulecode - loc.rulecode = ( if @loc.genpragma - then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of - -- type errors in the rule. It will definitely not be precise, and may take some additional - -- source space, but let's see if it's worth it in practice. - else empty - ) - >-< @loc.declHead - >-< indent ((column @rhs.pos - 2) `max` 2) - ( if @loc.genpragma - then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma - else @rhs.semfunc - ) - >#< "in" - loc.pragma = ppLinePragma @lhs.options (line @rhs.pos) (file @rhs.pos) - loc.endpragma = ppWithLineNr (\ln -> ppLinePragma @lhs.options (ln+1) @lhs.mainFile) - loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos - loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos)) - - -- Note: we also ensure that all rules are functions, so that they are not made part of any closures - -- but are lambda-lifted instead. - loc.declHead = "let" >#< @name >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "=" - loc.argPats - = ppSpaced - [ case mbAttr of - Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> - case Map.lookup nm @lhs.localAttrTypes of - Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp) - Nothing -> pp strNm - Just attr | not (noPerStateTypeSigs @lhs.options) -> - case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of - Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc) - Nothing -> pp strNm - _ -> pp strNm - | (strNm, mbAttr) <- Map.assocs @rhs.attrs - ] - - loc.argExprs = ppSpaced $ Map.keys @rhs.attrs - loc.stepcode = \kind -> - let mkBind (pat,expr) = "let" >#< pat >#< "=" >#< expr >#< "in" - in if kind `compatibleRule` @pure - then Right $ mkBind (@pattern.sem_lhs, @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs)) - >-< vlist (map mkBind @pattern.extraDefs) - else Left $ IncompatibleRuleKind @name kind - - lhs.mrules = Map.singleton @name @loc.stepcode - -ATTR Expression [ | | tks : {[HsToken]} ] -SEM Expression - | Expression lhs.tks = @tks - -{ -dummyPat :: Options -> Bool -> PP_Doc -dummyPat opts noArgs - | not noArgs = empty - | strictDummyToken opts = text "()" - | otherwise = text "(_ : unit)" - -dummyArg :: Options -> Bool -> PP_Doc -dummyArg opts noArgs - | not noArgs = empty - | otherwise = text "()" - -dummyType :: Options -> Bool -> PP_Doc -dummyType opts noArgs - | not noArgs = empty - | otherwise = text "unit" -} - -ATTR Expression [ | | pos : {Pos} ] -SEM Expression | Expression lhs.pos = @pos - --- pattern and expression semantics -ATTR Pattern [ | | sem_lhs : { PP_Doc } ] -ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ] -ATTR Pattern Patterns [ | | extraDefs USE {++} {[]} : {[(PP_Doc,PP_Doc)]} ] - -SEM Pattern - | Alias loc.var = text $ attrname @lhs.options False @field @attr - loc.hasTp = isJust @loc.mbTp - loc.o_sigs = typeSigs @lhs.options - - lhs.sem_lhs = ppArg (@loc.hasTp && @loc.o_sigs) @loc.var (maybe (text "?no type?") ppTp @loc.mbTp) - lhs.extraDefs = if @pat.isUnderscore - then [] - else [ (@pat.sem_lhs, @loc.var) ] - | Product lhs.sem_lhs = pp_block "(" ")" "," @pats.sem_lhs - | Constr lhs.sem_lhs = pp_parens $ @name >#< pp_block "(" ")" "," @pats.sem_lhs - | Underscore lhs.sem_lhs = text "_" - | Irrefutable lhs.sem_lhs = pp_parens (text "lazy" >#< @pat.sem_lhs) - -- note that the above has the inverse meaning compared to Haskell: - -- the above forces the evaluation of a lazy value. It seems appropriate though. - --- Check if a pattern is just an underscore -ATTR Pattern [ | | isUnderscore:{Bool}] -SEM Pattern - | Constr lhs.isUnderscore = False - | Product lhs.isUnderscore = False - | Alias lhs.isUnderscore = False - | Underscore lhs.isUnderscore = True - --- Collect the attributes defined by a pattern -ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ] -SEM Pattern | Alias - lhs.attrs = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs - --- All attribute types of this pattern --- Todo: if possible, make attribute types part of the pattern -ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ] -SEM Pattern | Alias - loc.mbTp = if @field == _LHS - then Map.lookup @attr @lhs.synmap - else if @field == _LOC - then Map.lookup @attr @lhs.localAttrTypes - else Nothing - lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp - >-< @pat.attrTypes - --- Collect the attributes used by the right-hand side -ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] -SEM HsToken - | AGLocal lhs.attrs = Map.singleton (fieldname @var) Nothing - | AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST' - then Nothing -- should not be used in the first place - else Just $ mkNonLocalAttr (@field == _LHS) @field @attr - lhs.attrs = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr - -{ -data NonLocalAttr - = AttrInh Identifier Identifier - | AttrSyn Identifier Identifier deriving Show - -mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr -mkNonLocalAttr True = AttrInh -- True: inherited attr -mkNonLocalAttr False = AttrSyn - -lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs -lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns - --- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that --- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. --- However, for now we simply decide to return Nothing in this case, which skips the type annotation. -lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupType child name attrMp childMp - | noParameters childTp = Just ppDoc - | otherwise = Nothing - where - attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs - childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp - nonterm = extractNonterminal childTp - childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp - ppDoc = ppTp attrTp - -noParameters :: Type -> Bool -noParameters (Haskell _) = True -noParameters (NT _ args _) = null args -} - -ATTR Expression [ | | semfunc : {PP_Doc} ] - -SEM Expression - | Expression lhs.attrs = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks - lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks - loc.inhhstoken = Inh_HsToken @lhs.options - --- child visit map -ATTR Visit - Visits - EProduction - EProductions - ENonterminal - ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} - | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} ] - -ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.allchildvisit = @nonts.childvisit - --- code for the invocation of the visit: --- * "follow" is the pretty print of the code that follows this step, and is thus the code that comprises the continuation. --- * the child state contain a field which is the operation to invoke --- * we create a parameter with the inputs to the visit and the continuation --- * the continuation obtains the resulting outputs plus the updated state -SEM Visit | Visit - loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits - lhs.childvisit = Map.singleton @ident @loc.invokecode - loc.invokecode - = \chld childTp kind follow -> -- "chld" is the name of the child at the place of invocation, and "kind" the kind of the calling visit - let code = cont >-< inps >-< call - - childNmTo = text $ stname chld @to - childNmFrom = text $ stname chld @from - childTpArgs = case childTp of - NT _ args _ -> args - _ -> error "generate visit call: type of the child is not a nonterminal!" - - -- cont is parameterized with the outputs of the child and brings them in scope - cont = "let" >#< contNm >#< ppArg @loc.o_sigs (ppRecordVal cont_in) cont_in_tp >#< "=" - >-< indent 2 follow -- the continuation-code - >#< "in" - cont_in = [ nm_outarg i @lhs.nt @ident >#< "=" >#< attrname @lhs.options True chld i | i <- Set.toList @syn ] - ++ case @loc.nextVisitInfo of - NoneVis -> [] - _ -> [ nm_outarg_cont @lhs.nt @ident >#< "=" >#< childNmTo ] - cont_in_tp = ppTypeParams childTpArgs >#< @loc.nameTOut_visit - - -- defines the input records to the visit function - inps = "let" >#< inpsNm >#< "=" >#< ppRecordVal - [ nm_inh @lhs.nt @ident >#< "=" >#< ppRecordVal inps_in - , nm_cont @lhs.nt @ident >#< "=" >#< contNm - ] >#< "in" - inps_in = [ nm_inarg i @lhs.nt @ident >#< "=" >#< attrname @lhs.options False chld i | i <- Set.toList @inh ] - - -- the call to the visit function, with possible the need to specify which visit function to dispatch to - call = childNmFrom >|< "." >|< nm_invoke @lhs.nt @from >#< arg - arg = case @loc.prevVisitInfo of - NoneVis -> error "error: invocation of a visit from a state that has no next visits" - OneVis _ -> pp inpsNm - ManyVis -> pp_parens (con_visit @lhs.nt @ident >#< inpsNm) - in if kind `compatibleKind` @kind - then Right code - else Left $ IncompatibleVisitKind chld @ident kind @kind - -{ -contNm = text "__cont_" -inpsNm = text "__inps_" - --- a `compatibleKind` b means: can kind b be invoked from a -compatibleKind :: VisitKind -> VisitKind -> Bool -compatibleKind _ _ = True - -compatibleRule :: VisitKind -> Bool -> Bool -compatibleRule (VisitPure _) False = False -compatibleRule _ _ = True -} - -------------------------------------------------------------------------------- --- Properties of rules -------------------------------------------------------------------------------- - --- Construct an environment that counts how often certain rules are used -ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ] -ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ] - -SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage -SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1 -SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo - -{ -unionWithSum = Map.unionWith (+) -} - --- Collect in what visit-kinds a rule is used -ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ] -SEM VisitStep | Sem - lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind) - -ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ] -SEM EProduction | EProduction - rules.ruleKinds = @visits.ruleKinds - -SEM ERule | ERule - loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds - loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds - -ATTR Pattern Patterns [ anyLazyKind : Bool | | ] - - -------------------------------------------------------------------------------- --- Intra attributes -------------------------------------------------------------------------------- -{ -uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) -uwSetUnion = Map.unionWith Set.union - -uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) -uwMapUnion = Map.unionWith Map.union -} -ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} - | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ] - -ATTR Visit Visits [ terminaldefs : {Set String} | | ] -ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ] - -SEM EChild | ETerm - lhs.terminaldefs = Set.singleton $ fieldname @name - -SEM EProduction | EProduction - visits.allintramap = @visits.intramap - visits.terminaldefs = @children.terminaldefs - -SEM Visit - | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap - lhs.intramap = Map.singleton @from @loc.thisintra - loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap - loc.uses = let mp1 = @steps.uses - mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ] - in mp1 `Map.union` mp2 - loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh - loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs - loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ] - -ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)} - ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ] -ATTR Visit Visits - VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)} - ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ] - -SEM ERule - | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs - lhs.ruleuses = Map.singleton @name @rhs.attrs - -SEM EProduction - | EProduction visits.ruledefs = @rules.ruledefs - visits.ruleuses = @rules.ruleuses - -ATTR Visit Visits - EProduction - EProductions - ENonterminal - ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} - visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ] - -SEM Visit - | Visit lhs.visitdefs = Map.singleton @ident @syn - lhs.visituses = Map.singleton @ident @inh - -ATTR Visit Visits - VisitSteps VisitStep - EProduction EProductions - ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)} - avisituses : {Map VisitIdentifier (Set Identifier)} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs - nonts.avisituses = @nonts.visituses - -ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String} - uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] -SEM VisitStep - | Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs - lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses - | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs - lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ] - in Map.insert (stname @child @from) Nothing $ convert $ - maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses - -------------------------------------------------------------------------------- --- Identification of lazy intra defs within a production --- --- These identifiers will not be marked as strict in rules and state closures -------------------------------------------------------------------------------- - -ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ] -ATTR ERules ERule [ lazyIntras : {Set String} | | ] - -SEM Visit | Visit - loc.lazyIntrasInh = case @kind of - VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs - _ -> Set.empty - lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras - -SEM VisitStep | PureGroup - lhs.lazyIntras = if @ordered - then @steps.lazyIntras - else @steps.defs - -SEM EProduction | EProduction - loc.lazyIntras = @visits.lazyIntras - -------------------------------------------------------------------------------- --- Pretty printing of haskell code -------------------------------------------------------------------------------- - --- note: this function produces strings, which are passed to showTokens which --- preserves layout. --- note: this may not be that important for ocaml code in comparison to Haskell -SEM HsTokens [ || tks : {[(Pos,String)]} ] - | Cons lhs.tks = @hd.tok : @tl.tks - | Nil lhs.tks = [] - -SEM HsToken - | AGLocal loc.tok = (@pos,fieldname @var) - -SEM HsToken [ || tok:{(Pos,String)}] - | AGField - loc.addTrace = case @rdesc of - Just d -> \x -> "(prerr_endline " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ "; " ++ x ++ ")" - Nothing -> id - lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr) - - | HsToken lhs.tok = (@pos, @value) - - | CharToken lhs.tok = (@pos, if null @value - then "" - else showCharShort (head @value) - ) - - | StrToken lhs.tok = (@pos, showStrShort @value) - | Err lhs.tok = (@pos, "") - --- --- Distribute single-visit-next map downward --- - -ATTR EProductions EProduction Visits Visit - [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ] - -SEM ENonterminal | ENonterminal - prods.nextVisits = @nextVisits - prods.prevVisits = @prevVisits - --- --- Collect and distribute the from/to states of a visit --- - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit - [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ] - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep - [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ] - -SEM Visit | Visit - lhs.fromToStates = Map.singleton @ident (@from, @to) - -SEM ExecutionPlan | ExecutionPlan - nonts.allFromToStates = @nonts.fromToStates - -SEM VisitStep | ChildVisit - (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates - - --- --- Collect and distribute the actual types of children of productions --- - -ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ] -ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ] - -SEM EProduction | EProduction - loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes - -SEM EChild | EChild ETerm - lhs.childTypes = Map.singleton @name @tp - --- --- Distribute types of local attributes --- - -ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ] -ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ] -ATTR ERules ERule Pattern Patterns [ localAttrTypes : {Map Identifier Type} | | ] - -SEM ENonterminal | ENonterminal - prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes - -SEM EProduction | EProduction - loc.localAttrTypes = Map.findWithDefault Map.empty @con @lhs.localAttrTypes - --- --- Collect and distribute visit kinds --- - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep - [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ] - -SEM Visit | Visit - lhs.visitKinds = Map.singleton @ident @kind - -SEM ExecutionPlan | ExecutionPlan - nonts.allVisitKinds = @nonts.visitKinds - --- --- Collect and distribute the initial state of nonterminals --- - -ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ] -ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep - [ allInitStates : {Map NontermIdent Int} | | ] - -SEM ENonterminal | ENonterminal - lhs.initStates = Map.singleton @nt @initial - -SEM ExecutionPlan | ExecutionPlan - nonts.allInitStates = @nonts.initStates - -SEM EChild | EChild - loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates - --- --- Push the nonterminal type downward --- - -ATTR EProductions EProduction [ ntType : Type | | ] -SEM ENonterminal | ENonterminal - loc.ntType = NT @nt (map show @params) False - --- --- Collect errors contained in rules that should be yielded when the --- rules are scheduled. --- - -ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] -SEM ERule | ERule - lhs.errors = case @mbError of - Just e | @loc.used > 0 -> Seq.singleton e - _ -> Seq.empty +-- As expected, the code generation for ML resembles the code generation for Haskell quite a bit. +-- However, there are several differences: +-- * no inline pragmas +-- * no strictness annotations (not needed) +-- * separating data types from code +-- +-- Generator conventions: +-- * we generate functions definitions with an 'and' binding and a match statement +-- * for some type aliasses, we'll introduce module decls in addition to a type +-- +-- Future work: +-- * abuse the module system more? +-- * parse ocaml blocks? +-- * lazy evaluation? +-- +-- Other comments: +-- * Empty records are not allowed in Ocaml. Mapping them to units. +-- * line pragmas. There are now line pragmas around the body of rules. +-- There cannot be syntactical mistakes in the patterns. However, there can be +-- type errors if a function returns a value with a type that differs from what +-- is expected. It's then not clear which location is reported. +-- Also, errors in type signatures are not caught. +-- However, usually, the problematic cases are syntax errors, and these are +-- prevented by parsing the definitions first. + +INCLUDE "ExecutionPlan.ag" +INCLUDE "Patterns.ag" +INCLUDE "Expression.ag" +INCLUDE "HsToken.ag" + +imports +{ +import ExecutionPlan +import Pretty +import PPUtil +import Options +import Data.Monoid(mappend,mempty) +import Data.Maybe +import Data.Graph +import Debug.Trace +import System.IO +import System.Directory +import System.FilePath +import UU.Scanner.Position + +import TokenDef +import HsToken +import ErrorMessages + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Sequence(Seq) +import qualified Data.Sequence as Seq +import Data.Foldable(toList) +} + +ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild + [ mainFile, mainName : String | | ] + +------------------------------------------------------------------------------- +-- Options +------------------------------------------------------------------------------- +ATTR ExecutionPlan + ENonterminals ENonterminal + EProductions EProduction + ERules ERule + EChildren EChild + Expression + HsToken HsTokens HsTokensRoot + Pattern Patterns + Visits Visit + VisitSteps VisitStep [ options : {Options} | | ] +ATTR EProductions EProduction [ rename : {Bool} | | ] + +SEM ENonterminal | ENonterminal + prods.rename = rename @lhs.options + +------------------------------------------------------------------------------- +-- Context info (nonterminal ident, constructor ident, nonterm params, etc.) +------------------------------------------------------------------------------- + +ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ] +SEM ENonterminal | ENonterminal + prods.nt = @nt + +ATTR EChildren EChild ERules ERule Visits Visit [ con : ConstructorIdent | | ] + +SEM EProduction | EProduction children.con = @con + rules.con = @con + visits.con = @con + +ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ] +SEM ENonterminal | ENonterminal + prods.params = @params + +------------------------------------------------------------------------------- +-- output attributes: we make a distinction between data declarations +-- and code +------------------------------------------------------------------------------- +ATTR ExecutionPlan [ | | datas, code, modules : {PP_Doc} ] + +SEM ExecutionPlan | ExecutionPlan + lhs.code = @nonts.code >-< @loc.wrappersExtra + lhs.datas = @nonts.datas >-< @loc.commonExtra + +ATTR ENonterminal ENonterminals + [ wrappers : {Set NontermIdent} | | datas,code,modules USE {>-<} {empty} : {PP_Doc} ] + +SEM ExecutionPlan | ExecutionPlan + nonts.wrappers = @wrappers + +SEM ENonterminal | ENonterminal + lhs.datas = ( text "" + >-< "(* *** " ++ getName @nt ++ " *** [data] *)") + >-< (if dataTypes @lhs.options + then pp "(* data *)" + >-< @loc.datatypeNt + >-< @loc.datatypeProds + >-< "" + else empty) + >-< (if @loc.hasWrapper + then pp "(* wrapper *)" + >-< @loc.wr_inh + >-< @loc.wr_syn + >-< "" + else empty) + >-< (if semfuns @lhs.options + then pp "(* semantic domain *)" + >-< @loc.t_init + >-< @loc.t_states + >-< @loc.c_states + >-< @prods.t_visits + >-< "" + else empty) + + lhs.code = ( text "" + >-< "(* *** " ++ getName @nt ++ " *** [code] *)") + >-< (if dataTypes @lhs.options + then pp "(* constructor functions *)" + >-< @loc.datatypeCon + else empty) + >-< (if @loc.hasWrapper + then pp "(* wrapper *)" + >-< @loc.wrapper + >-< "" + else empty) + >-< (if folds @lhs.options + then "(* cata *)" + >-< @loc.sem_nt + >-< "" + else empty) + >-< (if semfuns @lhs.options + then "(* semantic domain *)" + >-< @prods.sem_prod + >-< "" + else empty) + + -- note: we assume that these module declarations are not recursive, and + -- that their parameters do not depends on types generated by AG in the + -- same file. + lhs.modules = @loc.moduleDecl + + loc.hasWrapper = @nt `Set.member` @lhs.wrappers + +------------------------------------------------------------------------------- +-- Nonterminal datatype +------------------------------------------------------------------------------- +ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} | | ] + +SEM ExecutionPlan | ExecutionPlan + nonts.typeSyns = @typeSyns + +{ +ppRecordTp :: PP a => [a] -> PP_Doc +ppRecordTp es + | null es = text "unit" + | otherwise = pp_block "{" "}" "; " (map pp es) + +ppRecordVal :: PP a => [a] -> PP_Doc +ppRecordVal es + | null es = text "()" + | otherwise = pp_block "{" "}" "; " (map pp es) + +ppFieldsVal :: Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc +ppFieldsVal record fields + | null fields = text "()" + | record = ppRecordVal [ r >#< "=" >#< x | (r,x,_,_) <- fields ] + | otherwise = pp_block "(" ")" "," [ x | (_,x,_,_) <- fields ] + +ppFieldsType :: Bool -> Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc +ppFieldsType record defor fields + | null fields = text "unit" + | record = ppRecordTp [ r >#< ":" >#< (if defor then d else f) | (r,_,d,f) <- fields ] + | otherwise = pp_block "(" ")" "*" [ if defor then d else f | (_,_,d,f) <- fields ] +} + + +-- for each nonterminal, the following data types in ocmal: +-- * data type for the nonterminal, with a constructor for +-- each production. The constructor takes a single field +-- with the type explained below. +-- * for each production, a record type comprising the +-- children of the production. +-- +-- * class contexts are ignored +-- * at most one type variable +-- +-- aliasses: lists, tuples +-- *** think about maps, sets, etc. Perhaps the name of +-- the alias should become a local module name. +-- + +SEM ENonterminal | ENonterminal + loc.t_params = ppTypeParams @params + loc.aliasPre = "and" >#< @loc.t_params >#< @nt >#< "=" + loc.aliasMod = @loc.aliasPre >#< modName @nt >|< ".t" + loc.datatypeNt + = case lookup @nt @lhs.typeSyns of + -- generate special code for certain type aliasses + Just (List t) -> @loc.aliasPre >#< ppTp t >#< "list" + Just (Maybe t) -> @loc.aliasPre >#< ppTp t >#< "option" + Just (Tuple ts) -> @loc.aliasPre >#< (pp_block "(" ")" " * " $ map (ppTp . snd) ts) + + Just (Map k v) -> @loc.aliasMod + Just (IntMap t) -> @loc.aliasMod + Just (OrdSet t) -> @loc.aliasMod + Just IntSet -> @loc.aliasMod + + -- use the constructor-based data-type generation for all other types + _ -> "and" >#< @loc.t_params >#< @nt >#< "=" + >-< ( if null @prods.datatype + then pp "unit" + else indent 2 $ vlist @prods.datatype_call + ) + + loc.datatypeCon + = case lookup @nt @lhs.typeSyns of + Just _ -> empty -- no constructor funs for type aliasses + Nothing -> vlist @prods.datatype_con + + loc.moduleDecl + = let ppModule :: PP a => a -> PP_Doc + ppModule expr = "module" >#< modName @nt >#< "=" + in case lookup @nt @lhs.typeSyns of + Just (Map k _) -> ppModule ("Map.Make" >#< pp_parens (ppTp k)) + Just (IntMap _) -> ppModule ("Map.Make ()") + Just (OrdSet t) -> ppModule ("Set.Make" >#< pp_parens (ppTp t)) + Just IntSet -> ppModule ("Set.Make (struct type t = int let compare = Pervasives.compare end)") + _ -> empty + + loc.datatypeProds = vlist @prods.datatype + +ATTR EProduction [ | | datatype, datatype_call, datatype_con : {PP_Doc} ] +ATTR EProductions [ | | datatype, datatype_call, datatype_con USE {:} {[]} : {[PP_Doc]} ] + +SEM EProduction | EProduction + loc.o_records = dataRecords @lhs.options + loc.t_params = ppTypeParams @lhs.params + loc.t_c_params = ppTypeParams (cont_tvar : map pp @params) + loc.conname = conname @lhs.rename @lhs.nt @con + loc.recname = pp "fields_" >|< @loc.conname + lhs.datatype = "and" >#< @loc.t_params >#< @loc.recname >#< "=" + >#< ppFieldsType @loc.o_records False @children.sigs + lhs.datatype_call = pp "|" >#< @loc.conname >#< "of" >#< pp_parens (@loc.t_params >#< @loc.recname) + lhs.datatype_con + = let funNm = @lhs.nt >|< "_" >|< @con + decl = "and" >#< ppFunDecl @loc.o_sigs funNm params (@loc.t_params >#< @lhs.nt) body + params = [ (x, t) | (_,x,_,t) <- @children.sigs ] + body = @loc.conname >#< ppFieldsVal @loc.o_records @children.sigs + in decl + +ATTR EChild EChildren [ | | sigs USE {++} {[]} : {[(PP_Doc,PP_Doc,PP_Doc,PP_Doc)]} ] + +SEM EChild + | EChild ETerm + loc.tpDocFor = ppTp $ removeDeforested @tp + loc.tpDocDefor = ppTp $ forceDeforested @tp + loc.fieldNm = text $ recordFieldname @lhs.nt @lhs.con @name + loc.childNm = text (fieldname @name) + loc.field = (@loc.fieldNm, @loc.childNm, @loc.tpDocDefor, @loc.tpDocFor) + | EChild lhs.sigs = case @kind of + ChildAttr -> [] -- higher order attributes are not part of the data type + _ -> [@loc.field] + | ETerm lhs.sigs = [@loc.field] + +{ +ppTp :: Type -> PP_Doc +ppTp tp = case tp of + Haskell t -> pp t -- ocaml type + NT nt tps deforested + | nt == _SELF -> pp "?SELF?" + | null tps -> ppNontTp nt deforested + | otherwise -> pp_parens (ppSpaced (map pp_parens tps) >#< ppNontTp nt deforested) + Self -> pp "?SELF?" + +ppNontTp :: NontermIdent -> Bool -> PP_Doc +ppNontTp nt True = pp "t_" >|< pp nt +ppNontTp nt False = pp nt + +-- multiple type parameters go into a tuple +ppTypeParams :: PP a => [a] -> PP_Doc +ppTypeParams [] = empty +ppTypeParams [x] = pp x +ppTypeParams xs = pp_block "(" ")" "," (map pp xs) +} + +------------------------------------------------------------------------------- +-- Nonterminal semantic function +------------------------------------------------------------------------------- +SEM ENonterminal | ENonterminal + loc.fsemname = \x -> prefix @lhs.options ++ show x + loc.semname = @loc.fsemname @nt + loc.frecarg = \t x -> case t of + NT nt _ _ -> pp_parens (@fsemname nt >#< x) + _ -> x + + loc.sem_param_tp = @loc.t_params >#< @nt + loc.sem_res_tp = @loc.t_params >#< @loc.t_type + loc.sem_tp = @loc.sem_param_tp >#< "->" >#< @loc.sem_res_tp + + loc.o_sigs = typeSigs @lhs.options + loc.sem_nt_body = "match arg with" >-< (indent 2 $ @prods.sem_nt) + loc.sem_nt = let genSem :: PP a => a -> PP_Doc -> PP_Doc + genSem nm body = "and" >#< ppFunDecl @loc.o_sigs (pp @loc.semname) [(pp nm, @loc.sem_param_tp)] @loc.sem_res_tp body + genAlias alts = genSem (pp "arg") (pp "match arg with" >-< (indent 2 $ vlist $ map (pp "|" >#<) alts)) + genMap v = let body = modName @nt >|< ".fold" >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" >#< els + els = case v of + NT nt _ _ -> pp_parens (modName @nt >|< ".map" >#< @loc.fsemname nt >#< "m") + _ -> pp "m" + in genSem "m" body + genSet mbNt = let body = "List.fold_right" >#< @loc.semname >|< "_Entry" >#< + els (pp_parens (modName @nt >|< ".elements" >#< "s")) >#< @loc.semname >|< "_Nil" + els r = maybe r (\nt -> pp_parens ("List.map" >#< @loc.fsemname nt >#< r)) mbNt + in genSem "s" body + in case lookup @nt @lhs.typeSyns of + -- generate special code for some aliasses + Just (List t) -> let body = "List.fold_right" >#< @loc.semname >|< "_Cons" >#< els >#< @loc.semname >|< "_Nil" + els = case t of + NT nt _ _ -> pp_parens ("List.map" >#< @loc.fsemname nt >#< "list") + _ -> pp "list" + in genSem "list" body + Just (Tuple ts) -> let pat = pp_parens (ppCommas $ map fst ts) + body = @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @loc.frecarg (snd t) (pp $ fst t)) ts) + in genSem pat body + Just (Map _ v) -> genMap v + Just (IntMap v) -> genMap v + Just (Maybe t) -> genAlias + [ "None" >#< "->" >#< "=" >#< @loc.semname >|< "_Nothing" + , "Some" >#< "just" >#< "->" >#< @loc.semname >|< "_Just" >#< @frecarg t (pp "just") + ] + Just (OrdSet t) -> genSet $ case t of + NT nt _ _ -> Just nt + _ -> Nothing + Just (IntSet) -> genSet Nothing + + -- structural fold for the remaining cases + _ -> genSem "arg" @loc.sem_nt_body + +{ +-- convention for nonterminals to module names +modName :: NontermIdent -> PP_Doc +modName nt = pp "M_" >|< pp nt + +ppFunDecl :: Bool -> PP_Doc -> [(PP_Doc,PP_Doc)] -> PP_Doc -> PP_Doc -> PP_Doc +ppFunDecl gensigs nm args resSig expr = body where + body = nm >#< ppSpaced (map arg args) >#< ppRes >#< "=" + >-< indent 2 expr + arg (arg,tp) = ppArg gensigs arg tp + ppRes + | gensigs = ":" >#< resSig + | otherwise = empty + +ppArg :: Bool -> PP_Doc -> PP_Doc -> PP_Doc +ppArg gensigs arg tp + | gensigs = pp_parens (arg >#< ":" >#< tp) + | otherwise = arg + +} + +-- The number of productions +ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ] +SEM EProduction | EProduction lhs.count = {1} + +-- The per-production match-expr cases for the sem_NT function +ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ] +SEM EProduction | EProduction + lhs.sem_nt = "|" >#< conname @lhs.rename @lhs.nt @con >#< ppFieldsVal @loc.o_records @children.sigs >#< "->" >#< + prefix @lhs.options >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw + +ATTR EChild [ | | argnamesw : { PP_Doc } ] +ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ] + +SEM EChild + | EChild lhs.argnamesw = case @kind of + ChildSyntax -> "(" >#< prefix @lhs.options >|< @loc.nt >#< @name >|< "_" >#< ")" + ChildAttr -> empty -- no sem-case for a higher-order child + ChildReplace tp -> "(" >#< prefix @lhs.options >|< extractNonterminal tp >#< @name >|< "_" >#< ")" + | ETerm lhs.argnamesw = text $ fieldname @name + +------------------------------------------------------------------------------- +-- Types of attributes +------------------------------------------------------------------------------- +ATTR ExecutionPlan + ENonterminals + ENonterminal [ inhmap : {Map NontermIdent Attributes} + synmap : {Map NontermIdent Attributes} | | ] + +ATTR EProductions EProduction + ERules ERule + Patterns Pattern + Visits + Visit [ inhmap : {Attributes} + synmap : {Attributes} + allInhmap : {Map NontermIdent Attributes} + allSynmap : {Map NontermIdent Attributes} | | ] + +SEM ENonterminal + | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap + (Just prods.synmap) = Map.lookup @nt @lhs.synmap + prods.allInhmap = @lhs.inhmap + prods.allSynmap = @lhs.synmap + +------------------------------------------------------------------------------- +-- State datatypes +------------------------------------------------------------------------------- +{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)} + +ATTR Visit [ | | allvisits : { VisitStateState }] +ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}] +ATTR EProduction + EProductions [ | | allvisits: {[VisitStateState]}] + +SEM Visit + | Visit lhs.allvisits = (@ident, @from, @to) + +SEM EProductions + | Cons lhs.allvisits = @hd.allvisits -- just pick the first production + | Nil lhs.allvisits = error "Every nonterminal should have at least 1 production" + +-- type of tree in a given state s +SEM ENonterminal | ENonterminal + loc.allstates = orderStates @initial @prods.allvisits + loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits + loc.t_type = type_nt_sem_top @nt + loc.t_c_params = ppTypeParams (cont_tvar : map pp @params) + + -- the initial "s" type: contains the "attach" function that delivers the initial st + loc.t_init = "and" >#< @loc.t_params >#< @loc.t_type >#< "=" >#< pp_braces ( nm_attach @nt >#< ":" >#< "unit" >#< "->" >#< @loc.t_params >#< type_nt_sem @nt @initial) + + -- the "s" type in a given state: contains the invoke function to go to a next state + loc.t_states = vlist $ map (\st -> + let s_st = type_nt_state @nt st + t_st = type_nt_sem @nt st + c_st = type_caller @nt st + nextVisits = Map.findWithDefault ManyVis st @nextVisits + decl = "and" >#< @loc.t_params >#< t_st >#< "=" + in case nextVisits of + NoneVis -> decl >#< "unit" -- final state: no more subsequent visits + _ -> decl >#< ppRecordVal [ nm_invoke @nt st >#< ":" >#< cont_tvar >#< "." >#< @loc.t_c_params >#< c_st >#< "->" >#< cont_tvar ] + ) @loc.allstates + +{ +-- +-- conventions +-- + +-- type of the state of a node: a closure containing the children states and attributes, +-- with code of type 'type_nt_sem' that represents the subsequent visits to successor states. +type_nt_state nt st = "s_" >|< nt >|< "_" >|< st + +-- type of a visit to a node (the initial, and when in a given state) +-- an instance of this type is called the "semantics" +type_nt_sem_top nt = "t_" >|< nt +type_nt_sem nt st = type_nt_sem_top nt >|< "_s" >|< st + +-- type of a caller (contains visit selection + inputs + continuation) +type_caller nt st = "c_" >|< nt >|< "_s" >|< st + +-- names of records +nm_attach nt = "attach_">|< nt +nm_invoke nt st = "inv_" >|< nt >|< "_s" >|< st + +-- name of the type variable representing the result type of the continuation +cont_tvar = text "'cont__" + + +-- order states in reverse topological order so that successor states are +-- earlier in the resulting list. +orderStates :: StateIdentifier -> [VisitStateState] -> [StateIdentifier] +orderStates initial edges = res where + source = Map.singleton initial Set.empty -- ensures that the initial state is in graph even when there are no edges + targets = [ Map.singleton t Set.empty | (_,_,t) <- edges ] + deps = [ Map.singleton f (Set.singleton t) | (_,f,t) <- edges ] + + mp = Map.unionsWith Set.union (source : (targets ++ deps)) + es = [ (f,f,Set.toList ts) | (f,ts) <- Map.toList mp ] + cps = stronglyConnComp es + res = flattenSCCs cps +} + +-- type of a caller that selects a visit v from state s of the child, and +-- provides a continuation of the caller after the visit to the child +SEM ENonterminal | ENonterminal + loc.c_states = vlist $ map (\st -> + let nt_st = type_nt_state @nt st + c_st = type_caller @nt st + outg = filter (\(_,f,_) -> f == st) @prods.allvisits + nextVisits = Map.findWithDefault ManyVis st @nextVisits + declHead = "and" >#< @loc.t_c_params >#< c_st >#< "=" + visitcons = vlist $ map (\(v,_,_) -> + "|" >#< con_visit @nt v >#< "of" >#< @loc.t_c_params >#< type_caller_visit @nt v + ) outg + in case nextVisits of -- slight optimization for when there is only one visit + NoneVis -> empty -- st is final state, no subsequent visits, thus no more caller info + OneVis v -> declHead >#< @loc.t_c_params >#< type_caller_visit @nt v + ManyVis -> declHead >-< indent 3 visitcons + ) @loc.allstates + +{ +type_caller_visit nt v = "c_" >|< nt >|< "_v" >|< v +con_visit nt v = "C_" >|< nt >|< "_v" >|< v + +-- field names +nm_inh nt v = "inh_" >|< nt >|< "_v" >|< v +nm_cont nt v = "cont_" >|< nt >|< "_v" >|< v +} + +-- type t_visit of a call to a visit v (inputs to the visit + continuation of the parents that gets the output + new state of the child) +ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ] + +SEM EProductions | Cons + lhs.t_visits = @hd.t_visits + -- just pick the first production (these results are the same for all of them) + -- todo: that means we should actually represent visit declarations in the AST... + +SEM Visit | Visit + loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident + loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident + loc.nameNextState = type_nt_sem @lhs.nt @to + loc.nameCaller_visit = type_caller_visit @lhs.nt @ident + + loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state? + + loc.t_params = ppTypeParams @lhs.params + loc.t_c_params = ppTypeParams (cont_tvar : map pp @lhs.params) + + -- data type decls for the t_visit type + -- we generate a type for the caller of a visit, the arguments of the visit and the result of the visit + lhs.t_visits = "and" >#< @loc.t_c_params >#< @loc.nameCaller_visit >#< "=" >#< ppRecordTp + [ nm_inh @lhs.nt @ident >#< ":" >#< @loc.t_params >#< conNmTVisitIn @lhs.nt @ident + , nm_cont @lhs.nt @ident >#< ":" >#< @loc.t_params >#< conNmTVisitOut @lhs.nt @ident >#< "->" >#< cont_tvar + ] + >-< "and" >#< @loc.t_params >#< @loc.nameTIn_visit >#< "=" >#< ppRecordTp @loc.inhpart + >-< "and" >#< @loc.t_params >#< @loc.nameTOut_visit >#< "=" >#< ppRecordTp (@loc.synpart ++ @loc.contpart) + + loc.contpart = case @loc.nextVisitInfo of + NoneVis -> [] -- don't provide a continuation at all + _ -> [ nm_outarg_cont @lhs.nt @ident >#< ":" >#< @loc.t_params >#< @loc.nameNextState ] -- normal route: select the next semantics + + loc.inhpart = @loc.ppTypeList nm_inarg @inh @lhs.inhmap + loc.synpart = @loc.ppTypeList nm_outarg @syn @lhs.synmap + loc.ppTypeList = \f s m -> map (\i -> case Map.lookup i m of + Just tp -> f i @lhs.nt @ident >#< ":" >#< ppTp tp ) $ Set.toList s + +{ +-- more naming conventions +nm_inarg nm nt v = "i_" >|< nm >|< "_" >|< nt >|< "_v" >|< v +nm_outarg nm nt v = "o_" >|< nm >|< "_" >|< nt >|< "_v" >|< v +nm_outarg_cont = nm_outarg "_cont" + +conNmTVisit nt vId = "t_" >|< nt >|< "_v" >|< vId +conNmTVisitIn nt vId = "t_" >|< nt >|< "_vIn" >|< vId +conNmTVisitOut nt vId = "t_" >|< nt >|< "_vOut" >|< vId + +-- todo: remove ppMonadType +ppMonadType :: Options -> PP_Doc +ppMonadType opts + | parallelInvoke opts = text "IO" + | otherwise = text "Identity" +} + +------------------------------------------------------------------------------- +-- Inh and Syn wrappers +------------------------------------------------------------------------------- +SEM ENonterminal | ENonterminal + loc.wr_inh = @loc.genwrap "inh" @loc.wr_inhs1 -- todo: is perhaps a mistake in 2hs + loc.wr_syn = @loc.genwrap "syn" @loc.wr_syns + loc.genwrap = \nm attrs -> + "and" >#< @loc.t_params >#< nm >|< "_" >|< @nt >#< "=" >#< ppRecordTp + [ i >|< "_" >|< nm >|< "_" >|< @nt >#< ":" >#< ppTp t | (i,t) <- attrs ] + + loc.inhAttrs = fromJust $ Map.lookup @nt @lhs.inhmap + loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.inhAttrs + loc.wr_inhs1 = Map.toList @loc.inhAttrs + loc.wr_filter = if kennedyWarren @lhs.options && lateHigherOrderBinding @lhs.options + then Map.delete idLateBindingAttr + else id + loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap + + loc.wrapname = text ("wrap_" ++ show @nt) + loc.inhname = text ("inh_" ++ show @nt) + loc.synname = text ("syn_" ++ show @nt) + loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits + + loc.wrapArgSemTp = @loc.t_params >#< @loc.t_type + loc.wrapArgInhTp = @loc.t_params >#< @loc.inhname + loc.wrapArgPats = ppRecordVal [ i >|< "_inh_" >|< @nt >#< "=" >#< lhsname @lhs.options True i | (i,_) <- @loc.wr_inhs1 ] + loc.wrapResTp = @loc.t_params >#< @loc.synname + loc.wrapper = "and" >#< ppFunDecl @loc.o_sigs @loc.wrapname [(pp "act", @loc.wrapArgSemTp), (@loc.wrapArgPats, @loc.wrapArgInhTp)] @loc.wrapResTp @loc.wrapperPreamble + loc.wrapperPreamble + = ( if lateHigherOrderBinding @lhs.options + then "let" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName >#< "in" + else empty + ) -- initial attribute for late binding + >-< @loc.wrapperBody + loc.wrapperBody + = case @initialv of + [] -> text "{ }" -- case where there are no inherited or synthesized attributes + (initv:_) -> -- TODO: take care of multiple visits + let attach = "let" >#< "sem" >#< "=" >#< "act." >|< nm_attach @nt >#< "()" >#< "in" -- run attach code + + -- result transformer to wrapper output record + pat = ppRecordVal [ nm_outarg i @nt initv >#< "=" >#< lhsname @lhs.options False i | (i,_) <- @loc.wr_syns ] + bld = ppRecordVal [ i >|< "_syn_" >|< @nt >#< "=" >#< lhsname @lhs.options False i | (i,_) <- @loc.wr_syns ] + res = "let res = function" >#< pat >#< "->" >#< bld >#< "in" + + -- input to the visit (inh attrs + continuation) + inps = "let" >#< "inps" >#< "=" >#< ppRecordVal [ nm_inarg i @nt initv >#< "=" >#< lhsname @lhs.options True i | (i,_) <- @loc.wr_inhs ] >#< "in" + arg = "let" >#< "arg" >#< "=" >#< argcon >#< argrec >#< "in" + argcon = case @loc.firstVisitInfo of + ManyVis -> con_visit @nt initv + _ -> empty + argrec = ppRecordVal + [ nm_inh @nt initv >#< "=" >#< "inps" + , nm_cont @nt initv >#< "=" >#< "res" + ] + invoke = "sem." >|< nm_invoke @nt @initial >#< "arg" -- invoke the visit + in attach >-< res >-< inps >-< arg >-< invoke + +------------------------------------------------------------------------------- +-- Collection of NT / Production sem funs references +------------------------------------------------------------------------------- + +ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ] +SEM ENonterminal | ENonterminal + lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs + lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps + loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname + loc.semFunBndTp = @loc.semFunBndNm >#< ":" >#< @loc.sem_tp + loc.semFunBndNm = lateSemNtLabel @nt + +SEM EProduction | EProduction + lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef + lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp + loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname + loc.semFunBndTp = @loc.semFunBndNm >#< ":" >#< @loc.sem_tp + loc.semFunBndNm = lateSemConLabel @lhs.nt @con + +-- Generate a dictionary that contains the semantics of all semantic functions +SEM ExecutionPlan | ExecutionPlan + loc.wrappersExtra = if lateHigherOrderBinding @lhs.options + then @loc.lateSemBndDef + else empty + loc.commonExtra = if lateHigherOrderBinding @lhs.options + then @loc.lateSemBndTp + else empty + loc.lateSemBndTp = "and" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< ppRecordTp (toList @nonts.semFunBndTps) + loc.lateSemBndDef = "and" >#< lateBindingFieldNm @lhs.mainName >#< ":" >#< lateBindingTypeNm @lhs.mainName >#< "=" + >-< (indent 2 $ ppRecordVal $ toList @nonts.semFunBndDefs) + +------------------------------------------------------------------------------- +-- Production semantic functions +------------------------------------------------------------------------------- +ATTR EProduction [ | | sem_prod : {PP_Doc} ] +ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ] + +ATTR EProduction EProductions [ initial : {StateIdentifier} + allstates : {[StateIdentifier]} | | ] +SEM ENonterminal | ENonterminal + prods.initial = @initial + prods.allstates = @loc.allstates + +SEM EProduction | EProduction + loc.o_sigs = typeSigs @lhs.options + loc.t_type = type_nt_sem_top @lhs.nt + loc.semname = prefix @lhs.options >|< @lhs.nt >|< "_" >|< @con + loc.sem_res_tp = @loc.t_params >#< @loc.t_type + loc.sem_tp = pp_block "" "" "->" [ d | (_,_,d,_) <- @children.sigs ] >#< "->" >#< @loc.sem_res_tp + + loc.initializer + = -- some actions, performed upon attaching a child, can + -- be specified here in the form of a let-expression. + -- The resulting bindings of these actions are + -- in scope of the rules of the production + empty -- nothing for now + + loc.sem_prod = "and" >#< ppFunDecl @loc.o_sigs @loc.semname [ (x,d) | (_,x,d,_) <- @children.sigs ] @loc.sem_res_tp @loc.prod_body + loc.prod_body + = @loc.initializer + >-< "{" >#< nm_attach @lhs.nt >#< "=" >#< "function () ->" + >-< indent 2 + ( "(* rules of production" >#< @con >#< "*)" + >-< @rules.sem_rules + >-< "(* states of production" >#< @con >#< "*)" + >-< vlist @loc.statefuns + >-< nm_st @lhs.initial + ) + >#< "}" + + -- the semantic function of a production: defines a series of states and + -- their transitions. Two sorts of functions are important: + -- k-functions: inspect the caller_type to find out which visit the + -- caller wants and then dispatches that visit and continuation. + -- v-functions: the actual code of the visit. + loc.statefuns = map @loc.genstfn @lhs.allstates + loc.genstfn + = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits + stNm = nm_st st + + -- note about the initial state: the initial state should be the only + -- state-binding that is not a function. It is non-recursive, its definition does + -- not involve side effect, and its not needed + -- anywhere except to be delivered as initial result. + stDef body = "let" >#< stNm >#< (if st == @lhs.initial then empty else @loc.stargs st) >#< "=" + >-< indent 2 body >#< "in" + + in case nextVisitInfo of + NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced + -- thus generating it is not needed (and omitting it may catch some small mistakes). + if st == @lhs.initial + then stDef (pp "unit") -- empty state + else empty -- no state generated + _ -> stDef $ mklets (@loc.stvs st ++ @loc.stks st) $ ppRecordVal + [ nm_invoke @lhs.nt st >#< "=" >#< nm_k st ] + + loc.stargs + = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap in ppSpaced + [ case mbAttr of + Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> + case Map.lookup nm @loc.localAttrTypes of + Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp) + Nothing -> pp strNm + Just attr | not (noPerStateTypeSigs @lhs.options) -> + case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of + Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc) + Nothing -> pp strNm + _ -> pp strNm + | (strNm, mbAttr) <- Map.assocs attrs + ] >#< dummyPat @lhs.options (Map.null attrs) + + -- produces the "k" function that inspect the caller argument to dispatch a visit + loc.stvisits = \st -> filter (\(_,f,_) -> f == st) @visits.allvisits + loc.stks + = \st -> let stvisits = @loc.stvisits st + def = ppFunDecl False {- @loc.o_sigs -} (pp $ nm_k st) + [(pp "arg", @loc.t_c_params >#< type_caller @lhs.nt st)] (pp cont_tvar) body + + nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits + body = case nextVisitInfo of + NoneVis -> text "?no next visit?" + OneVis v -> dispatch "arg" v + ManyVis -> let alt (v,_,_) = "|" >#< con_visit @lhs.nt v >#< "chosen" >#< "->" >-< indent 2 (dispatch "chosen" v) + in "match arg with" >-< (indent 2 $ vlist $ map alt stvisits) + + dispatch nm v = "let" >#< ppRecordVal + [ nm_inh @lhs.nt v >#< "=" >#< "inp" + , nm_cont @lhs.nt v >#< "=" >#< "cont" ] + >#< "=" >#< pp nm + >-< "in" >#< "cont" >#< pp_parens (nm_visit v >#< "inp") -- call cont with res of visit + + in if null stvisits + then [] + else [ "(* k-function for production" >#< @con >#< " *)" >-< def ] + + loc.stvs = \st -> [ppf | (f,ppf) <- @visits.sem_visit, f == st] + visits.mrules = @rules.mrules + +{ +nm_visit v = "__v" >|< v +nm_k st = "__k" >|< st +nm_st st = "__st" >|< st + +mklets :: (PP b, PP c) => [b] -> c -> PP_Doc +mklets defs body = res where + ppLet def = "let" >#< def >#< "in" + res = vlist (map ppLet defs) >-< body +} + +------------------------------------------------------------------------------- +-- Visit semantic functions +------------------------------------------------------------------------------- +ATTR Visit [ | | sem_visit : { (StateIdentifier,PP_Doc) } ] +ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,PP_Doc)] } ] + +SEM Visit | Visit + loc.o_sigs = typeSigs @lhs.options + lhs.sem_visit = ( @from + , let resTp = @loc.t_params >#< @loc.nameTOut_visit + argTp = @loc.t_params >#< @loc.nameTIn_visit + argMatch = ppRecordVal [ nm_inarg i @lhs.nt @ident >#< "=" >#< lhsname @lhs.options True i | i <- Set.toList @inh ] + in ppFunDecl @loc.o_sigs (nm_visit @ident) [(argMatch, argTp)] resTp @steps.sem_steps + ) + + steps.follow = @loc.nextStBuild >-< @loc.resultval + + loc.nextArgsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap + loc.nextArgs = ppSpaced $ Map.keys $ @loc.nextArgsMp + loc.nextStExp = nm_st @to >#< @loc.nextArgs >#< dummyArg @lhs.options (Map.null @loc.nextArgsMp) + + loc.resultval = ppRecordVal + ( [ nm_outarg i @lhs.nt @ident >#< "=" >#< lhsname @lhs.options False i | i <- Set.toList @syn ] + ++ [ @loc.nextStRefExp ]) + + (loc.nextStBuild, loc.nextStRefExp) + = case @loc.nextVisitInfo of + NoneVis -> (empty, empty) + _ -> ( "let" >#< nextStName >#< "=" >#< @loc.nextStExp >#< "in" + , nm_outarg_cont @lhs.nt @ident >#< "=" >#< nextStName) + +{ +resultValName :: String +resultValName = "__result_" + +nextStName :: String +nextStName = "__st_" +} + +-- Propagate the visit kind to the steps +ATTR VisitStep VisitSteps [ kind : VisitKind | | ] +SEM Visit | Visit steps.kind = @kind + +-- the steps in this group should be executed in a pure fashion +SEM VisitStep | PureGroup + steps.kind = VisitPure @ordered + +-- follow: the code of steps that follows after the VisitStep +ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> Either Error PP_Doc)} | | ] +ATTR VisitStep VisitSteps [ follow : PP_Doc | | sem_steps USE {>-<} {empty} : PP_Doc ] + +-- continuation flow (passing the right steps as left follow steps) +SEM VisitSteps + | Cons hd.follow = @tl.sem_steps + lhs.sem_steps = @hd.sem_steps + | Nil lhs.sem_steps = @lhs.follow + +SEM VisitStep + | Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules + (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind of + Left e -> (Seq.singleton e, empty) + Right stmt -> (Seq.empty, stmt) + lhs.sem_steps = @loc.sem_steps >-< @lhs.follow + | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros + (lhs.errors,loc.sem_steps,lhs.defs,lhs.uses) + = case @loc.attachItf @lhs.kind of + Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) + Right (code, defs, uses) -> (Seq.empty, code, defs, uses) + lhs.sem_steps = @loc.sem_steps >-< @lhs.follow + | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit + loc.childType = Map.findWithDefault (error ("type of child " ++ show @child ++ " is not in the childTypes map! " ++ show @lhs.childTypes)) @child @lhs.childTypes + (lhs.errors, lhs.sem_steps) = case @loc.visitItf @child @loc.childType @lhs.kind @lhs.follow of + Left e -> (Seq.singleton e, empty) + Right steps -> (Seq.empty, steps) + | Sim -- simply propagates + | PureGroup -- simply propagates + +-- +-- Some properties of VisitStep(s) +-- + +-- Number of steps in a 'Sim' block +ATTR VisitSteps [ | | size : Int ] +SEM VisitSteps + | Nil lhs.size = 0 + | Cons lhs.size = 1 + @tl.size + +-- Number the steps in a 'Sim' block +ATTR VisitSteps VisitStep [ | index : Int | ] +SEM VisitSteps | Cons + hd.index = @lhs.index -- copy rule + tl.index = 1 + @lhs.index + lhs.index = @tl.index -- copy rule +SEM Visit | Visit steps.index = 0 +SEM VisitStep | Sim steps.index = 0 + lhs.index = @lhs.index -- needed for if we ever allow nested Sims + +-- Biggest number of steps in previous blocks that used parallel invocation +-- This number - 1 (minimum 0) is the number of references for parallel invocation created +ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ] +SEM Visit | Visit steps.prevMaxSimRefs = 0 +SEM VisitStep | Sim + lhs.prevMaxSimRefs = if @loc.useParallel + then @lhs.prevMaxSimRefs `max` (@steps.index - 1) -- possibly new references made + else @lhs.prevMaxSimRefs -- no references created + +-- Is this the last step? +ATTR VisitSteps VisitStep [ | | isLast : Bool ] +ATTR VisitStep [ isLast : Bool | | ] +SEM VisitSteps + | Nil lhs.isLast = True + | Cons lhs.isLast = False + hd.isLast = @tl.isLast + +-- Use parallel invocation: only when option enabled and there is more than one visit to a child +-- Todo: implement a parallel evaluator +SEM VisitSteps VisitStep [ useParallel : Bool | | ] +SEM Visit | Visit steps.useParallel = False +SEM VisitStep | Sim loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1 + +-- Child introduction +ATTR EChild EChildren + [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ] + +ATTR Visits Visit VisitSteps VisitStep + [ childintros : {Map Identifier (VisitKind -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ] + +SEM EProduction | EProduction + visits.childintros = @children.childintros + +SEM EChild + | ETerm lhs.childintros = Map.singleton @name (\_ -> Right (empty, Set.empty, Map.empty)) + | EChild lhs.childintros = Map.singleton @name @loc.introcode + loc.isDefor = case @tp of + NT _ _ defor -> defor + _ -> False + loc.valcode = case @kind of + ChildSyntax -> @name >|< "_" + ChildAttr -> -- decide if we need to invoke the sem-function under the hood + let head | not @loc.isDefor = if lateHigherOrderBinding @lhs.options + then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr + else prefix @lhs.options >|< @loc.nt + | otherwise = empty -- no need to intro a terminal + in pp_parens (head >#< instname @name) + ChildReplace _ -> -- the higher-order attribute is actually a function that transforms + -- the semantics of the child (always deforested) + pp_parens (instname @name >#< @name >|< "_") + loc.aroundcode = if @hasAround + then locname @lhs.options @name >|< "_around" + else empty + loc.introcode = \kind -> let pat = text $ stname @name @loc.initSt + attach = pp_parens (@loc.aroundcode >#< @loc.valcode) >|< "." >|< nm_attach @loc.nt >#< "()" + decl = pat >#< "=" >#< attach + in if compatibleAttach kind @loc.nt @lhs.options + then Right ( "let" >#< decl >#< "in" + , Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro + , case @kind of -- variables used by the child introduction + ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr + ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options) + then id -- the sem dictionary attr is not used + else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) + ) $ + ( if @hasAround + then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing + else id + ) $ Map.empty + ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function + ChildSyntax -> Map.empty + ) + else Left $ IncompatibleAttachKind @name kind + loc.nt = extractNonterminal @tp + +{ +stname :: Identifier -> Int -> String +stname child st = "_" ++ getName child ++ "X" ++ show st + +-- should actually return some conversion info +compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool +compatibleAttach _ _ _ = True +} + +-- rules +ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc} + mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> Either Error PP_Doc)} ] + +SEM ERule | ERule + lhs.sem_rules = if @loc.used == 0 + then empty + else @loc.rulecode + loc.rulecode = ( if @loc.genpragma + then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of + -- type errors in the rule. It will definitely not be precise, and may take some additional + -- source space, but let's see if it's worth it in practice. + else empty + ) + >-< @loc.declHead + >-< indent ((column @rhs.pos - 2) `max` 2) + ( if @loc.genpragma + then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma + else @rhs.semfunc + ) + >#< "in" + loc.pragma = ppLinePragma @lhs.options (line @rhs.pos) (file @rhs.pos) + loc.endpragma = ppWithLineNr (\ln -> ppLinePragma @lhs.options (ln+1) @lhs.mainFile) + loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos + loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos)) + + -- Note: we also ensure that all rules are functions, so that they are not made part of any closures + -- but are lambda-lifted instead. + loc.declHead = "let" >#< @name >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "=" + loc.argPats + = ppSpaced + [ case mbAttr of + Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> + case Map.lookup nm @lhs.localAttrTypes of + Just tp -> pp_parens (strNm >#< ":" >#< ppTp tp) + Nothing -> pp strNm + Just attr | not (noPerStateTypeSigs @lhs.options) -> + case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of + Just tpDoc -> pp_parens (strNm >#< ":" >#< tpDoc) + Nothing -> pp strNm + _ -> pp strNm + | (strNm, mbAttr) <- Map.assocs @rhs.attrs + ] + + loc.argExprs = ppSpaced $ Map.keys @rhs.attrs + loc.stepcode = \kind -> + let mkBind (pat,expr) = "let" >#< pat >#< "=" >#< expr >#< "in" + in if kind `compatibleRule` @pure + then Right $ mkBind (@pattern.sem_lhs, @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs)) + >-< vlist (map mkBind @pattern.extraDefs) + else Left $ IncompatibleRuleKind @name kind + + lhs.mrules = Map.singleton @name @loc.stepcode + +ATTR Expression [ | | tks : {[HsToken]} ] +SEM Expression + | Expression lhs.tks = @tks + +{ +dummyPat :: Options -> Bool -> PP_Doc +dummyPat opts noArgs + | not noArgs = empty + | strictDummyToken opts = text "()" + | otherwise = text "(_ : unit)" + +dummyArg :: Options -> Bool -> PP_Doc +dummyArg opts noArgs + | not noArgs = empty + | otherwise = text "()" + +dummyType :: Options -> Bool -> PP_Doc +dummyType opts noArgs + | not noArgs = empty + | otherwise = text "unit" +} + +ATTR Expression [ | | pos : {Pos} ] +SEM Expression | Expression lhs.pos = @pos + +-- pattern and expression semantics +ATTR Pattern [ | | sem_lhs : { PP_Doc } ] +ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ] +ATTR Pattern Patterns [ | | extraDefs USE {++} {[]} : {[(PP_Doc,PP_Doc)]} ] + +SEM Pattern + | Alias loc.var = text $ attrname @lhs.options False @field @attr + loc.hasTp = isJust @loc.mbTp + loc.o_sigs = typeSigs @lhs.options + + lhs.sem_lhs = ppArg (@loc.hasTp && @loc.o_sigs) @loc.var (maybe (text "?no type?") ppTp @loc.mbTp) + lhs.extraDefs = if @pat.isUnderscore + then [] + else [ (@pat.sem_lhs, @loc.var) ] + | Product lhs.sem_lhs = pp_block "(" ")" "," @pats.sem_lhs + | Constr lhs.sem_lhs = pp_parens $ @name >#< pp_block "(" ")" "," @pats.sem_lhs + | Underscore lhs.sem_lhs = text "_" + | Irrefutable lhs.sem_lhs = pp_parens (text "lazy" >#< @pat.sem_lhs) + -- note that the above has the inverse meaning compared to Haskell: + -- the above forces the evaluation of a lazy value. It seems appropriate though. + +-- Check if a pattern is just an underscore +ATTR Pattern [ | | isUnderscore:{Bool}] +SEM Pattern + | Constr lhs.isUnderscore = False + | Product lhs.isUnderscore = False + | Alias lhs.isUnderscore = False + | Underscore lhs.isUnderscore = True + +-- Collect the attributes defined by a pattern +ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ] +SEM Pattern | Alias + lhs.attrs = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs + +-- All attribute types of this pattern +-- Todo: if possible, make attribute types part of the pattern +ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ] +SEM Pattern | Alias + loc.mbTp = if @field == _LHS + then Map.lookup @attr @lhs.synmap + else if @field == _LOC + then Map.lookup @attr @lhs.localAttrTypes + else Nothing + lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp + >-< @pat.attrTypes + +-- Collect the attributes used by the right-hand side +ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] +SEM HsToken + | AGLocal lhs.attrs = Map.singleton (fieldname @var) Nothing + | AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST' + then Nothing -- should not be used in the first place + else Just $ mkNonLocalAttr (@field == _LHS) @field @attr + lhs.attrs = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr + +{ +data NonLocalAttr + = AttrInh Identifier Identifier + | AttrSyn Identifier Identifier deriving Show + +mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr +mkNonLocalAttr True = AttrInh -- True: inherited attr +mkNonLocalAttr False = AttrSyn + +lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc +lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs +lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns + +-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that +-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. +-- However, for now we simply decide to return Nothing in this case, which skips the type annotation. +lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc +lookupType child name attrMp childMp + | noParameters childTp = Just ppDoc + | otherwise = Nothing + where + attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs + childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp + nonterm = extractNonterminal childTp + childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp + ppDoc = ppTp attrTp + +noParameters :: Type -> Bool +noParameters (Haskell _) = True +noParameters (NT _ args _) = null args +} + +ATTR Expression [ | | semfunc : {PP_Doc} ] + +SEM Expression + | Expression lhs.attrs = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks + lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks + loc.inhhstoken = Inh_HsToken @lhs.options + +-- child visit map +ATTR Visit + Visits + EProduction + EProductions + ENonterminal + ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} + | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} ] + +ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> Type -> VisitKind -> PP_Doc -> Either Error PP_Doc)} | | ] + +SEM ExecutionPlan + | ExecutionPlan nonts.allchildvisit = @nonts.childvisit + +-- code for the invocation of the visit: +-- * "follow" is the pretty print of the code that follows this step, and is thus the code that comprises the continuation. +-- * the child state contain a field which is the operation to invoke +-- * we create a parameter with the inputs to the visit and the continuation +-- * the continuation obtains the resulting outputs plus the updated state +SEM Visit | Visit + loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits + lhs.childvisit = Map.singleton @ident @loc.invokecode + loc.invokecode + = \chld childTp kind follow -> -- "chld" is the name of the child at the place of invocation, and "kind" the kind of the calling visit + let code = cont >-< inps >-< call + + childNmTo = text $ stname chld @to + childNmFrom = text $ stname chld @from + childTpArgs = case childTp of + NT _ args _ -> args + _ -> error "generate visit call: type of the child is not a nonterminal!" + + -- cont is parameterized with the outputs of the child and brings them in scope + cont = "let" >#< contNm >#< ppArg @loc.o_sigs (ppRecordVal cont_in) cont_in_tp >#< "=" + >-< indent 2 follow -- the continuation-code + >#< "in" + cont_in = [ nm_outarg i @lhs.nt @ident >#< "=" >#< attrname @lhs.options True chld i | i <- Set.toList @syn ] + ++ case @loc.nextVisitInfo of + NoneVis -> [] + _ -> [ nm_outarg_cont @lhs.nt @ident >#< "=" >#< childNmTo ] + cont_in_tp = ppTypeParams childTpArgs >#< @loc.nameTOut_visit + + -- defines the input records to the visit function + inps = "let" >#< inpsNm >#< "=" >#< ppRecordVal + [ nm_inh @lhs.nt @ident >#< "=" >#< ppRecordVal inps_in + , nm_cont @lhs.nt @ident >#< "=" >#< contNm + ] >#< "in" + inps_in = [ nm_inarg i @lhs.nt @ident >#< "=" >#< attrname @lhs.options False chld i | i <- Set.toList @inh ] + + -- the call to the visit function, with possible the need to specify which visit function to dispatch to + call = childNmFrom >|< "." >|< nm_invoke @lhs.nt @from >#< arg + arg = case @loc.prevVisitInfo of + NoneVis -> error "error: invocation of a visit from a state that has no next visits" + OneVis _ -> pp inpsNm + ManyVis -> pp_parens (con_visit @lhs.nt @ident >#< inpsNm) + in if kind `compatibleKind` @kind + then Right code + else Left $ IncompatibleVisitKind chld @ident kind @kind + +{ +contNm = text "__cont_" +inpsNm = text "__inps_" + +-- a `compatibleKind` b means: can kind b be invoked from a +compatibleKind :: VisitKind -> VisitKind -> Bool +compatibleKind _ _ = True + +compatibleRule :: VisitKind -> Bool -> Bool +compatibleRule (VisitPure _) False = False +compatibleRule _ _ = True +} + +------------------------------------------------------------------------------- +-- Properties of rules +------------------------------------------------------------------------------- + +-- Construct an environment that counts how often certain rules are used +ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ] +ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ] + +SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage +SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1 +SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo + +{ +unionWithSum = Map.unionWith (+) +} + +-- Collect in what visit-kinds a rule is used +ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ] +SEM VisitStep | Sem + lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind) + +ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ] +SEM EProduction | EProduction + rules.ruleKinds = @visits.ruleKinds + +SEM ERule | ERule + loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds + loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds + +ATTR Pattern Patterns [ anyLazyKind : Bool | | ] + + +------------------------------------------------------------------------------- +-- Intra attributes +------------------------------------------------------------------------------- +{ +uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) +uwSetUnion = Map.unionWith Set.union + +uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) +uwMapUnion = Map.unionWith Map.union +} +ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} + | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ] + +ATTR Visit Visits [ terminaldefs : {Set String} | | ] +ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ] + +SEM EChild | ETerm + lhs.terminaldefs = Set.singleton $ fieldname @name + +SEM EProduction | EProduction + visits.allintramap = @visits.intramap + visits.terminaldefs = @children.terminaldefs + +SEM Visit + | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap + lhs.intramap = Map.singleton @from @loc.thisintra + loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap + loc.uses = let mp1 = @steps.uses + mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ] + in mp1 `Map.union` mp2 + loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh + loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs + loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ] + +ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)} + ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ] +ATTR Visit Visits + VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)} + ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ] + +SEM ERule + | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs + lhs.ruleuses = Map.singleton @name @rhs.attrs + +SEM EProduction + | EProduction visits.ruledefs = @rules.ruledefs + visits.ruleuses = @rules.ruleuses + +ATTR Visit Visits + EProduction + EProductions + ENonterminal + ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} + visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ] + +SEM Visit + | Visit lhs.visitdefs = Map.singleton @ident @syn + lhs.visituses = Map.singleton @ident @inh + +ATTR Visit Visits + VisitSteps VisitStep + EProduction EProductions + ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)} + avisituses : {Map VisitIdentifier (Set Identifier)} | | ] + +SEM ExecutionPlan + | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs + nonts.avisituses = @nonts.visituses + +ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String} + uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] +SEM VisitStep + | Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs + lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses + | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs + lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ] + in Map.insert (stname @child @from) Nothing $ convert $ + maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses + +------------------------------------------------------------------------------- +-- Identification of lazy intra defs within a production +-- +-- These identifiers will not be marked as strict in rules and state closures +------------------------------------------------------------------------------- + +ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ] +ATTR ERules ERule [ lazyIntras : {Set String} | | ] + +SEM Visit | Visit + loc.lazyIntrasInh = case @kind of + VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs + _ -> Set.empty + lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras + +SEM VisitStep | PureGroup + lhs.lazyIntras = if @ordered + then @steps.lazyIntras + else @steps.defs + +SEM EProduction | EProduction + loc.lazyIntras = @visits.lazyIntras + +------------------------------------------------------------------------------- +-- Pretty printing of haskell code +------------------------------------------------------------------------------- + +-- note: this function produces strings, which are passed to showTokens which +-- preserves layout. +-- note: this may not be that important for ocaml code in comparison to Haskell +SEM HsTokens [ || tks : {[(Pos,String)]} ] + | Cons lhs.tks = @hd.tok : @tl.tks + | Nil lhs.tks = [] + +SEM HsToken + | AGLocal loc.tok = (@pos,fieldname @var) + +SEM HsToken [ || tok:{(Pos,String)}] + | AGField + loc.addTrace = case @rdesc of + Just d -> \x -> "(prerr_endline " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ "; " ++ x ++ ")" + Nothing -> id + lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr) + + | HsToken lhs.tok = (@pos, @value) + + | CharToken lhs.tok = (@pos, if null @value + then "" + else showCharShort (head @value) + ) + + | StrToken lhs.tok = (@pos, showStrShort @value) + | Err lhs.tok = (@pos, "") + +-- +-- Distribute single-visit-next map downward +-- + +ATTR EProductions EProduction Visits Visit + [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ] + +SEM ENonterminal | ENonterminal + prods.nextVisits = @nextVisits + prods.prevVisits = @prevVisits + +-- +-- Collect and distribute the from/to states of a visit +-- + +ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit + [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ] + +ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep + [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ] + +SEM Visit | Visit + lhs.fromToStates = Map.singleton @ident (@from, @to) + +SEM ExecutionPlan | ExecutionPlan + nonts.allFromToStates = @nonts.fromToStates + +SEM VisitStep | ChildVisit + (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates + + +-- +-- Collect and distribute the actual types of children of productions +-- + +ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ] +ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ] + +SEM EProduction | EProduction + loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes + +SEM EChild | EChild ETerm + lhs.childTypes = Map.singleton @name @tp + +-- +-- Distribute types of local attributes +-- + +ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ] +ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ] +ATTR ERules ERule Pattern Patterns [ localAttrTypes : {Map Identifier Type} | | ] + +SEM ENonterminal | ENonterminal + prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes + +SEM EProduction | EProduction + loc.localAttrTypes = Map.findWithDefault Map.empty @con @lhs.localAttrTypes + +-- +-- Collect and distribute visit kinds +-- + +ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep + [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ] + +SEM Visit | Visit + lhs.visitKinds = Map.singleton @ident @kind + +SEM ExecutionPlan | ExecutionPlan + nonts.allVisitKinds = @nonts.visitKinds + +-- +-- Collect and distribute the initial state of nonterminals +-- + +ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ] +ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep + [ allInitStates : {Map NontermIdent Int} | | ] + +SEM ENonterminal | ENonterminal + lhs.initStates = Map.singleton @nt @initial + +SEM ExecutionPlan | ExecutionPlan + nonts.allInitStates = @nonts.initStates + +SEM EChild | EChild + loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates + +-- +-- Push the nonterminal type downward +-- + +ATTR EProductions EProduction [ ntType : Type | | ] +SEM ENonterminal | ENonterminal + loc.ntType = NT @nt (map show @params) False + +-- +-- Collect errors contained in rules that should be yielded when the +-- rules are scheduled. +-- + +ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] +SEM ERule | ERule + lhs.errors = case @mbError of + Just e | @loc.used > 0 -> Seq.singleton e + _ -> Seq.empty diff --git a/src-ag/ExecutionPlan2Clean.ag b/src-ag/ExecutionPlan2Clean.ag --- a/src-ag/ExecutionPlan2Clean.ag +++ b/src-ag/ExecutionPlan2Clean.ag @@ -1,1684 +1,1684 @@ -INCLUDE "ExecutionPlan.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "HsToken.ag" - -imports -{ -import ExecutionPlan -import Pretty -import PPUtil -import Options -import Data.Monoid(mappend,mempty) -import Data.Maybe -import Debug.Trace -import System.IO -import System.Directory -import System.FilePath -import UU.Scanner.Position - -import TokenDef -import HsToken -import ErrorMessages - -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Sequence(Seq) -import qualified Data.Sequence as Seq -import Data.Foldable(toList) -} - -ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild - [ importBlocks : PP_Doc - textBlocks : PP_Doc - iclModuleHeader : {String -> String -> String -> Bool -> String} - dclModuleHeader : {String -> String -> String -> Bool -> String} - mainFile : String - mainName : String - constructorTypeMap : {Map NontermIdent ConstructorType} | | ] - -------------------------------------------------------------------------------- --- Options -------------------------------------------------------------------------------- -ATTR ExecutionPlan - ENonterminals ENonterminal - EProductions EProduction - ERules ERule - EChildren EChild - Expression - HsToken HsTokens HsTokensRoot - Pattern Patterns - Visits Visit - VisitSteps VisitStep [ options : {Options} | | ] -ATTR EProductions EProduction [ rename : {Bool} | | ] - -SEM ENonterminal - | ENonterminal prods.rename = rename @lhs.options - -------------------------------------------------------------------------------- --- Context info (nonterminal ident, constructor ident, nonterm params, etc.) -------------------------------------------------------------------------------- - -ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ] -SEM ENonterminal - | ENonterminal prods.nt = @nt - -ATTR EChildren EChild ERules ERule Visits Visit - [ con : ConstructorIdent | | ] - -SEM EProduction - | EProduction children.con = @con - rules.con = @con - visits.con = @con - -ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ] -SEM ENonterminal | ENonterminal - prods.params = @params - -ATTR EProductions EProduction [ classCtxs : ClassContext | | ] -SEM ENonterminal | ENonterminal - prods.classCtxs = @classCtxs - -------------------------------------------------------------------------------- --- Default output -------------------------------------------------------------------------------- -ATTR ExecutionPlan [ | | output : {PP_Doc} - output_dcl : {PP_Doc} ] - -SEM ExecutionPlan - | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra - lhs.output_dcl = @nonts.output_dcl - -ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent} - | | output USE {>-<} {empty} : {PP_Doc} - output_dcl USE {>-<} {empty} : {PP_Doc}] - -SEM ExecutionPlan - | ExecutionPlan nonts.wrappers = @wrappers - -SEM ENonterminal - | ENonterminal lhs.output = ("// " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-') - >-< (if @loc.hasWrapper - then "// wrapper" - >-< @loc.wr_inh_icl - >-< @loc.wr_syn_icl - >-< @loc.wrapper_icl - >-< "" - else empty) - >-< (if folds @lhs.options - then "// cata" - >-< @loc.sem_nt - >-< "" - else empty) - >-< (if semfuns @lhs.options - then "// semantic domain" - >-< @loc.t_init_icl - >-< @loc.t_states_icl - >-< @loc.k_states - >-< @prods.sem_prod - >-< "" - else empty) - loc.hasWrapper = @nt `Set.member` @lhs.wrappers - - lhs.output_dcl = ("// " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-') - >-< (if dataTypes @lhs.options - then "// data" - >-< @loc.datatype - >-< "" - else empty) - >-< (if @loc.hasWrapper - then "// wrapper" - >-< @loc.wr_inh_dcl - >-< @loc.wr_syn_dcl - >-< @loc.wrapper_dcl - >-< "" - else empty) - >-< (if folds @lhs.options - then "// cata" - >-< @loc.semname >#< "::" >#< @loc.sem_tp - >-< "" - else empty) - >-< (if semfuns @lhs.options - then "// semantic domain" - >-< @loc.t_init_dcl - >-< @loc.t_states_dcl - >-< @prods.t_visits - >-< @prods.sem_prod_tys - >-< "" - else empty) - -------------------------------------------------------------------------------- --- Nonterminal datatype -------------------------------------------------------------------------------- -ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} - derivings : {Derivings} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.typeSyns = @typeSyns - nonts.derivings = @derivings - -SEM ENonterminal - | ENonterminal loc.classPP = ppClasses $ classCtxsToDocs @classCtxs - loc.aliasPre = "::" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< ":==" - loc.datatype = case lookup @nt @lhs.typeSyns of - Nothing -> "::" >#< @loc.classPP >#< @nt >#< @loc.t_params - >-< ( if null @prods.datatype - then empty - else if isRecordConstructor @nt @lhs.constructorTypeMap - then indent 2 $ "=" >#< @prods.recordtype - else indent 2 $ vlist $ ( ("=" >#< head @prods.datatype) - : (map ("|" >#<) $ tail @prods.datatype)) - ) - >-< indent 2 @loc.derivings - Just (List t) -> @loc.aliasPre >#< "[" >#< show t >#< "]" - Just (Maybe t) -> @loc.aliasPre >#< "Data.Maybe" >#< pp_parens (show t) - Just (Tuple ts) -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts) - Just (Either l r) -> @loc.aliasPre >#< "Data.Either" >#< pp_parens (show l) >#< pp_parens (show r) - Just (Map k v) -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v) - Just (IntMap t) -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t) - Just (OrdSet t) -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (show t) - Just IntSet -> @loc.aliasPre >#< "Data.IntSet.IntSet" --- Just x -> error $ "Type " ++ show x ++ " is not supported" - loc.derivings = case Map.lookup @nt @lhs.derivings of - Nothing -> empty - Just s -> if Set.null s - then empty - else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s) - -{ -classCtxsToDocs :: ClassContext -> [PP_Doc] -classCtxsToDocs = map toDoc where - toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args)) - -classConstrsToDocs :: [Type] -> [PP_Doc] -classConstrsToDocs = map ppTp - -ppClasses :: [PP_Doc] -> PP_Doc -ppClasses [] = empty -ppClasses xs = "|" >#< pp_block "" "" "&" xs - -ppQuants :: [Identifier] -> PP_Doc -ppQuants [] = empty -ppQuants ps = "E." >#< ppSpaced ps >#< ":" -} - -ATTR EProduction [ | | datatype : {PP_Doc} - recordtype : {PP_Doc} ] -ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} - recordtype : {PP_Doc} ] - --- we generate the data type in the type-class style instead of the GADT style --- the GADT extension may be required if equality constraints are used -SEM EProduction - | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1 - >#< conname @lhs.rename @lhs.nt @con - >#< ppConFields (dataRecords @lhs.options) @children.datatype - lhs.recordtype = @loc.quantPP1 >#< @loc.classPP1 - >#< ppConFields True @children.recordtype - loc.classPP1 = ppClasses (classConstrsToDocs @constraints) - loc.quantPP1 = ppQuants @params - -SEM EProductions - | Cons lhs.recordtype = @hd.recordtype - | Nil lhs.recordtype = empty - -{ --- first parameter indicates: generate a record or not -ppConFields :: Bool -> [PP_Doc] -> PP_Doc -ppConFields True flds = ppListSep "{" "}" ", " flds -ppConFields False flds = ppSpaced flds -} - - -ATTR EChild [ | | datatype : {PP_Doc} - recordtype : {PP_Doc} ] -ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]} - recordtype USE {:} {[]} : {[PP_Doc]} ] - --- Note: the child may be a higher-order attribute, and its semantics may be deforested -SEM EChild - | EChild ETerm - loc.tpDoc = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp - loc.strNm = recordFieldname @lhs.nt @lhs.con @name - loc.field = if dataRecords @lhs.options - then @loc.strNm >#< "::" >#< @loc.tpDoc - else @loc.tpDoc - loc.recordfield = @loc.strNm >#< "::" >#< @loc.tpDoc - loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x - | EChild lhs.datatype = case @kind of - ChildAttr -> empty -- higher order attributes are not part of the data type - _ -> @loc.field - - lhs.recordtype = case @kind of - ChildAttr -> empty -- higher order attributes are not part of the data type - _ -> @loc.recordfield - | ETerm lhs.datatype = @loc.field - lhs.recordtype = @loc.recordfield - -{ -ppTp :: Type -> PP_Doc -ppTp = text . typeToHaskellString Nothing [] -} - -------------------------------------------------------------------------------- --- Nonterminal semantic function -------------------------------------------------------------------------------- -SEM ENonterminal - | ENonterminal loc.fsemname = \x -> "sem_" ++ show x - loc.semname = @loc.fsemname @nt - loc.frecarg = \t x -> case t of - NT nt _ _ -> pp_parens (@fsemname nt >#< x) - _ -> pp x - - -- The sem_NT function is lazy in the AST: it depends on the application of "child" - -- rules to which extend the AST needs to be constructed. - loc.sem_tp = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params - loc.quantPP = ppQuants @params - - loc.sem_nt = @loc.semname >#< "::" >#< @loc.sem_tp - >-< case lookup @nt @lhs.typeSyns of - Nothing -> @prods.sem_nt - Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Cons" - >#< @loc.semname >|< "_Nil" - >#< case t of - NT nt _ _ -> pp_parens ("map" >#< @fsemname nt >#< "list") - _ -> pp "list" - Just (Maybe t) -> @loc.semname >#< "'Data.Maybe'.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing" - >-< @loc.semname >#< pp_parens ("'Data.Maybe'.Just just") >#< "=" - >#< @loc.semname >|< "_Just" >#< @frecarg t "just" - Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "=" - >#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts) - Just (Either l r) -> @loc.semname >#< "('Data.Either'.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left" - >-< @loc.semname >#< "('Data.Either'.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right" - Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "'Data.Map'.foldrWithKey" - >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" - >#< case v of - NT nt _ _ -> pp_parens ("'Data.Map'.map" >#< @fsemname nt >#< "m") - _ -> pp "m" - Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "'Data.IntMap'.foldWithKey" - >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" - >#< case v of - NT nt _ _ -> pp_parens ("'Data.IntMap'.map" >#< @fsemname nt >#< "m") - _ -> pp "m" - Just (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Entry" - >#< @loc.semname >|< "_Nil" - >#< pp_parens ( - ( case t of - NT nt _ _ -> pp_parens ("map" >#< @fsemname nt) - _ -> empty - ) >#< pp_parens ("'Data.IntSet'.elems" >#< "s") - ) - Just IntSet -> @loc.semname >#< "s" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Entry" - >#< @loc.semname >|< "_Nil" - >#< pp_parens ("'Data.IntSet'.elems" >#< "s") --- Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns - --- The number of productions -ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ] -SEM EProduction | EProduction lhs.count = {1} - --- The per-production cases for the sem_NT function -ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ] -SEM EProduction - | EProduction lhs.sem_nt = let lhs = "sem_" >|< @lhs.nt - rhs = "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw - cnnm = conname @lhs.rename @lhs.nt @con - in if isRecordConstructor @lhs.nt @lhs.constructorTypeMap - then lhs >#< "{" >#< cnnm >#< "|" >#< - pp_block "" "" "," (zipWith (\l r -> l >#< "=" >#< r) @children.recfields @children.argpats) >#< "}" >#< rhs - else lhs >#< "(" >#< cnnm >#< ppSpaced @children.argpats >#< ")" >#< rhs - -{ -isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool -isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor -} - -ATTR EChild [ | | argnamesw : { PP_Doc } ] -ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ] - -SEM EChild - | EChild lhs.argnamesw = case @kind of - ChildSyntax -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")" - ChildAttr -> empty -- no sem-case for a higher-order child - ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")" - | ETerm lhs.argnamesw = text $ fieldname @name - -------------------------------------------------------------------------------- --- Types of attributes -------------------------------------------------------------------------------- -ATTR ExecutionPlan - ENonterminals - ENonterminal [ inhmap : {Map NontermIdent Attributes} - synmap : {Map NontermIdent Attributes} | | ] - -ATTR EProductions EProduction - ERules ERule - Patterns Pattern - Visits - Visit [ inhmap : {Attributes} - synmap : {Attributes} - allInhmap : {Map NontermIdent Attributes} - allSynmap : {Map NontermIdent Attributes} | | ] - -SEM ENonterminal - | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap - (Just prods.synmap) = Map.lookup @nt @lhs.synmap - prods.allInhmap = @lhs.inhmap - prods.allSynmap = @lhs.synmap - -------------------------------------------------------------------------------- --- State datatypes -------------------------------------------------------------------------------- -{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)} - -ATTR Visit [ | | allvisits : { VisitStateState }] -ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}] -ATTR EProduction - EProductions [ | | allvisits: {[VisitStateState]}] - -SEM Visit - | Visit lhs.allvisits = (@ident, @from, @to) - -SEM EProductions - | Cons lhs.allvisits = @hd.allvisits -- just pick the first production - | Nil lhs.allvisits = error "Every nonterminal should have at least 1 production" - --- type of tree in a given state s -SEM ENonterminal - | ENonterminal loc.outedges = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits - loc.inedges = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits - loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges - loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits - loc.t_type = "T_" >|< @nt - loc.lt_type = "t_" >|< @nt - loc.t_params = ppSpaced @params - loc.t_init_icl = @loc.t_init_dcl >-< - "attach_" >|< @loc.t_type >#< pp_parens (@loc.t_type >#< @loc.lt_type) >#< "=" >#< @loc.lt_type - loc.t_init_dcl = "::" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type - >#< - pp_parens ( - ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params)) - loc.t_states_icl = vlist $ map (\st -> - let nt_st = @nt >|< "_s" >|< st - c_st = "C_" >|< nt_st - inv_st = "inv_" >|< nt_st - nextVisit = Map.findWithDefault ManyVis st @nextVisits - in case nextVisit of - NoneVis -> empty -- empty semantics - OneVis vId -> inv_st >#< pp_parens (c_st >#< "x") >#< "=" >#< "x" - ManyVis -> empty - ) $ Set.toList @loc.allstates - loc.t_states_dcl = vlist $ map (\st -> - let nt_st = @nt >|< "_s" >|< st - t_st = "T_" >|< nt_st - k_st = "K_" >|< nt_st - c_st = "C_" >|< nt_st - inv_st = "inv_" >|< nt_st - nextVisit = Map.findWithDefault ManyVis st @nextVisits - in case nextVisit of - NoneVis -> "::" >#< t_st >#< @loc.t_params >#< "=" >#< c_st -- empty semantics - OneVis vId -> "::" >#< t_st >#< @loc.t_params >#< "=" >#< c_st >#< (pp_parens (conNmTVisit @nt vId >#< @loc.t_params)) - ManyVis -> "::" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::" -- TODO : Cleanify - >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("E.t:" >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t")) - >#< "->" >#< t_st >#< @loc.t_params -- this is a conventional data type, but declared with GADT syntax - ) $ Set.toList @loc.allstates - --- type of a key which identifies a visit v from state s -SEM ENonterminal - | ENonterminal loc.k_type = "K_" ++ show @nt - loc.k_states = vlist $ map (\st -> - let nt_st = @nt >|< "_s" >|< st - k_st = "K_" >|< nt_st - outg = filter (\(v,f,t) -> f == st) @prods.allvisits - visitlist = vlist $ map (\(v,f,t) -> - @loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params) - ) outg - nextVisit = Map.findWithDefault ManyVis st @nextVisits - decl = "::" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist - in case nextVisit of - NoneVis -> empty - OneVis _ -> empty - ManyVis -> decl - ) $ Set.toList @loc.allstates - --- type of a visit v, with continuation as new state s -ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ] - -SEM EProductions - | Cons lhs.t_visits = @hd.t_visits -- just pick the first production - -SEM Visit - | Visit loc.nameT_visit = conNmTVisit @lhs.nt @ident - loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident - loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident - loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to - - loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state? - loc.typecon = case @kind of - VisitPure _ -> empty - VisitMonadic -> ppMonadType @lhs.options - - loc.t_params = ppSpaced @lhs.params - lhs.t_visits = "::" >#< @loc.nameT_visit >#< @loc.t_params >#< ":==" >#< - pp_parens (@loc.nameTIn_visit >#< @loc.t_params) - >#< ( if dummyTokenVisit @lhs.options - then "->" >#< dummyType @lhs.options True -- Additional (unused though) argument - else empty - ) - >#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params) - >-< "::" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#< - @loc.inhpart - >-< "::" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#< - @loc.synpart >#< case @loc.nextVisitInfo of - NoneVis -> empty -- don't return a continuation at all - _ -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params) -- normal route: select the next semantics - - loc.inhpart = @loc.ppTypeList @inh @lhs.inhmap - loc.synpart = @loc.ppTypeList @syn @lhs.synmap - loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of - Just tp -> ppTp tp ) $ Set.toList s - -{ -conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId -conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId -conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId -conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId - -ppMonadType :: Options -> PP_Doc -ppMonadType opts - | parallelInvoke opts = text "IO" - | otherwise = text "Identity" -} - -------------------------------------------------------------------------------- --- Inh and Syn wrappers -------------------------------------------------------------------------------- -SEM ENonterminal - | ENonterminal loc.wr_inh_icl = @loc.genwrap_icl "Inh" @loc.wr_inhs - loc.wr_syn_icl = @loc.genwrap_icl "Syn" @loc.wr_syns - loc.genwrap_icl = \nm attr -> - let tyConName = nm >|< "_" >|< @nt - in (let (d, _, _) = foldr (\(i, t) (d, c, n) -> (d >-< - i >|< "_" >|< tyConName >#< "::" >#< tyConName >#< "->" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t) - >-< i >|< "_" >|< tyConName >#< pp_parens (tyConName >#< unwords (replicate (n - c - 1) "_" ++ ["x"] ++ replicate c "_")) >#< "= x" - , c + 1, n) - ) (empty, 0, length attr) attr - in d) - loc.wr_inh_dcl = @loc.genwrap_dcl "Inh" @loc.wr_inhs - loc.wr_syn_dcl = @loc.genwrap_dcl "Syn" @loc.wr_syns - loc.genwrap_dcl = \nm attr -> - let tyConName = nm >|< "_" >|< @nt - in "::" >#< tyConName >#< @loc.t_params >#< "=" >#< tyConName -- >#< "{" - >#< (ppSpaced $ map (\(_,t) -> @loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t) attr) -- >#< "}" - >-< - (let (d, _, _) = foldr (\(i, t) (d, c, n) -> (d >-< - i >|< "_" >|< tyConName >#< "::" >#< tyConName >#< "->" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t) - , c + 1, n) - ) (empty, 0, length attr) attr - in d) - loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap - loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.synAttrs - loc.wr_inhs1 = Map.toList @loc.synAttrs - loc.wr_filter = if lateHigherOrderBinding @lhs.options - then Map.delete idLateBindingAttr - else id - loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap - loc.inhlist = map (lhsname @lhs.options True . fst) @loc.wr_inhs - loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1 - loc.synlist = map (lhsname @lhs.options False . fst) @loc.wr_syns - loc.wrapname = "wrap_" ++ show @nt - loc.inhname = "Inh_" ++ show @nt - loc.synname = "Syn_" ++ show @nt - loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits - loc.wrapper_icl = (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params -- TODO : Remove ? >#< "->" - >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params)) - >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act")) - >#< (@loc.addbang $ pp_parens (@loc.inhname - >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "=")) - >-< - indent 3 (case @initialv of - -- case where there are no inherited or synthesized attributes - [] -> text @loc.synname -- TODO : Remove? >#< " { }" - (initv:_) -> -- TODO: take care of multiple visits - let inCon = conNmTVisitIn @nt initv - outCon = conNmTVisitOut @nt initv - pat = @loc.addbang $ pp_parens $ pat0 - pat0 = outCon >#< ppSpaced @loc.synlist -- should be an "end" state, thus no continuation expected here - arg = inCon >#< ppSpaced @loc.inhlist1 - ind = case @loc.firstVisitInfo of - NoneVis -> error "wrapper: initial state should have a next visit but it has none" - OneVis _ -> empty - ManyVis -> @loc.k_type >|< "_v" >|< initv - extra = if dummyTokenVisit @lhs.options - then pp $ dummyArg @lhs.options True - else empty - convert = case Map.lookup initv @lhs.allVisitKinds of - Just kind -> case kind of - VisitPure _ -> text "lift" - VisitMonadic -> empty - _ -> empty - unMonad | monadicWrappers @lhs.options = empty - | otherwise = unMon @lhs.options - in unMonad >#< "(" - >-< indent 2 - ("act >>= \\" >#< @loc.addbang (pp "sem") >#< "->" -- run the per-node monadic code to get the initial state (of the root) - >-< "lift" >#< pp_parens arg >#< ">>= \\" >#< @loc.addbangWrap (pp "arg") >#< "->" - >-< convert >#< pp_parens ("inv_" >|< @nt >|< "_s" >|< @initial >#< "sem" >#< ind >#< "arg" >#< extra) >#< ">>= \\" >#< pat >#< "->" -- invoke initial state (of the root) - >-< "lift" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist) - ) - >-< ")" ) - >-< if lateHigherOrderBinding @lhs.options - then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName) - else empty - loc.wrapper_dcl = (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params -- TODO : Remove ? >#< "->" - >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params)) - -------------------------------------------------------------------------------- --- Collection of NT / Production sem funs references -------------------------------------------------------------------------------- - -ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ] -SEM ENonterminal | ENonterminal - lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs - lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps - loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname - loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp - loc.semFunBndNm = lateSemNtLabel @nt - -SEM EProduction | EProduction - lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef - lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp - loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname - loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp - loc.semFunBndNm = lateSemConLabel @lhs.nt @con - --- Generate a dictionary that contains the semantics of all semantic functions -SEM ExecutionPlan | ExecutionPlan - loc.wrappersExtra = if lateHigherOrderBinding @lhs.options - then @loc.lateSemBndDef - else empty - loc.commonExtra = if lateHigherOrderBinding @lhs.options - then @loc.lateSemBndTp - else empty - loc.lateSemBndTp = "::" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName - >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps) - loc.lateSemBndDef = lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName - >-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName - >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs ) - -------------------------------------------------------------------------------- --- Production semantic functions -------------------------------------------------------------------------------- -ATTR EProduction [ | | sem_prod : {PP_Doc} - sem_prod_tys : {PP_Doc} ] -ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} - sem_prod_tys USE {>-<} {empty} : {PP_Doc} ] - -ATTR EProduction EProductions [ initial : {StateIdentifier} - allstates : {Set StateIdentifier} | | ] -SEM ENonterminal - | ENonterminal prods.initial = @initial - prods.allstates = @loc.allstates - -ATTR EChild [ | | argtps : { PP_Doc } - argpats : { PP_Doc } - recfields USE {++} {[]} : { [Identifier] }] -ATTR EChildren [ | | argtps USE {:} {[]} : { [PP_Doc] } - argpats USE {:} {[]} : { [PP_Doc] } - recfields USE {++} {[]} : { [Identifier] }] - -SEM EChild - | EChild lhs.argtps = case @kind of - ChildSyntax -> pp_parens $ ppDefor @tp -- TODO Remove? >#< "->" - ChildReplace tp -> pp_parens $ ppDefor tp -- TODO Remove? >#< "->" - _ -> empty -- higher order attribute - loc.argpats = case @kind of - ChildSyntax -> @name >|< "_" -- no strictification of children semantics to allow infinite trees - ChildReplace _ -> @name >|< "_" - _ -> empty - - lhs.recfields = case @kind of - ChildSyntax -> [@name] -- no strictification of children semantics to allow infinite trees - ChildReplace _ -> [@name] - _ -> [] - - -- | ETerm lhs.argtps = (pp_parens $ show @tp) >#< "572->" -- TODO Remove? - | ETerm lhs.argtps = pp_parens $ show @tp - loc.argpats = @loc.addbang $ text $ fieldname @name -- terminals may be strict (perhaps this should become an option) - lhs.recfields = [@name] - -{ -ppDefor :: Type -> PP_Doc -ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args) -ppDefor (Haskell s) = text s -} - -SEM EProduction - | EProduction loc.t_type = "T_" >|< @lhs.nt - loc.t_params = ppSpaced @lhs.params - loc.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs - -- A bit ugly, but this code renames arguments and puts an underscore when the argument - -- is never used. This avoids compiler warnings of unused variables. - loc.args = map (\x -> let (name,arg) = case show x of - "" -> ("", empty) - '!':name -> ("arg_" ++ name, "!arg_" >|< name) - name -> ("arg_" ++ name, "arg_" >|< name) - in if null name || name `Set.member` @loc.usedArgs - then arg - else text "_") @children.argpats - loc.semname = "sem_" ++ show @lhs.nt ++ "_" ++ show @con - loc.sem_tp = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps - >#< (if length @children.argtps > 0 then "->" else "") - >#< @loc.t_type >#< @loc.t_params -- TODO Keep -> here? - loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints) - loc.quantPP2 = ppQuants (@lhs.params ++ @params) - - lhs.sem_prod_tys = @loc.semname >#< " ::" >#< @loc.sem_tp - - loc.sem_prod = @loc.semname >#< " ::" >#< @loc.sem_tp - >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.t_type) - @loc.mbInitializer @loc.outerlet ("lift" >#< "st" >|< @lhs.initial) - loc.mkSemBody = \prefix mbInit outerlet ret -> - case mbInit of - Nothing -> prefix >#< pp_parens ret >#< "where" - >-< indent 3 outerlet -- code for states and visits - Just m -> prefix >#< "(" >#< "do" -- TODO: desugar - >-< indent 1 ( - m - >-< "let" - >-< indent 2 outerlet -- code for the states and visits - >-< ret ) - >-< indent 1 ")" - - loc.mbInitializer = --some monadic actions, performed upon attaching a child, can - -- be specified here. The resulting bindings of these actions are - -- in scope of the rules of the production - if parallelInvoke @lhs.options - then (Nothing :: Maybe PP_Doc) -- perhaps do some per-node registation, etc. For now: nothing - else Nothing -- nothing special here - loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules - loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates - loc.genstfn = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits - prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits - stNm = "st" >|< st - lhs = bang stNm >#< "=" >#< - ( -- generating a lambda for the same reasons as generating - -- a lambda for rules: to ensure that overloading is - -- resolved for all visit functions and rules together. - if st == @lhs.initial - then empty - else "\\" >#< @loc.stargs st >#< "->" - ) - - cCon = "C_" >|< @lhs.nt >|< "_s" >|< st - bang | st == @lhs.initial = @loc.addbang -- initial state is not parameterized - | otherwise = id - - -- note about the initial state: the initial state should be the only - -- state-binding that is not a function. It is non-recursive and not needed - -- anywhere except delivered as initial result. This binding therefore does - -- not end up needlessly in any closure. - in case nextVisitInfo of - NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced - -- thus generating it is not needed (and omitting it may catch some small mistakes). - if st == @lhs.initial - then lhs >#< cCon -- empty state - else empty -- no state generated - OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId) - ManyVis -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st) - loc.stargs = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap - in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str - | otherwise = @loc.addbang (pp str) - in case mbAttr of - Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> - case Map.lookup nm @loc.localAttrTypes of - Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) - Nothing -> match - Just attr | not (noPerStateTypeSigs @lhs.options) -> - case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of - Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) - Nothing -> match - _ -> match - | (str,mbAttr) <- Map.assocs attrs - ] >#< dummyPat @lhs.options (Map.null attrs) - - loc.stks = \st -> if null (@loc.stvisits st) - then empty - else "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "t" >#< "->" >#< "t" - >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "=" - >#< "v" >|< v) $ @loc.stvisits st) - loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits - loc.stvs = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st] - visits.mrules = @rules.mrules - -{ -mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc -mklet prefix defs body = - prefix - >-< indent (length (show prefix)) - ("let" - >-< indent 4 defs - >-< "in" >#< body) -} - -------------------------------------------------------------------------------- --- Visit semantic functions -------------------------------------------------------------------------------- -ATTR Visit [ | | sem_visit : { (StateIdentifier,Bool -> PP_Doc) } ] -ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ] - -SEM Visit - | Visit lhs.sem_visit = ( @from - , \_ -> - -- TODO: Generate type signature "v" >|< @ident >#< "::" >#< @loc.nameTIn_visit >#< "->" >#< @loc.nameT_visit >#< @loc.t_params >-< - - -- Haskell: generate a lambda here as well instead of a function definition - -- >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats)) - -- Clean: generate a function - "v" >|< @ident >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats)) >#< "=" - >#< ( if dummyTokenVisit @lhs.options - then pp $ dummyPat @lhs.options True -- extra (but unused) argument - else empty - ) - -- >#< "->" - -- >#< "(" - >-< indent 10 (@loc.stepsInitial - >-< indent 4 @steps.sem_steps) >-< indent 10 @loc.stepsClosing - -- >#< ")" - ) - loc.stepsInitial = case @kind of - VisitPure False -> text "let" - VisitPure True -> empty - VisitMonadic -> text "do" - loc.stepsClosing = let decls = @loc.nextStBuild - >-< @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval - in case @kind of - VisitPure False -> indent 4 decls - >-< "in" >#< resultValName - VisitPure True -> "let" >#< decls - >-< indent 1 ("in" >#< resultValName) - VisitMonadic -> "let" >#< decls - >-< "lift" >#< resultValName - loc.vname = "v" >|< @ident - loc.inhpats = ppSpaced $ map (\arg -> pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh - loc.inhargs = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh - loc.synargs = ppSpaced $ map (\arg -> attrname @lhs.options False _LHS arg) $ Set.toList @syn - loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap - loc.nextargs = ppSpaced $ Map.keys $ @loc.nextargsMp - loc.nextst = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp) - loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef - (loc.nextStBuild, loc.nextStRef) - = case @loc.nextVisitInfo of - NoneVis -> (empty, empty) - _ -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName) - -{ -resultValName :: String -resultValName = "ag__result_" - -nextStName :: String -nextStName = "ag__st_" -} - --- Propagate the visit kind to the steps -ATTR VisitStep VisitSteps [ kind : VisitKind | | ] -SEM Visit | Visit steps.kind = @kind - --- the steps in this group should be executed in a pure fashion -SEM VisitStep | PureGroup - steps.kind = VisitPure @ordered - -ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ] -ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ] -SEM VisitStep - | Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules - (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of - Left e -> (Seq.singleton e, empty) - Right stmt -> (Seq.empty, stmt) - | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros - (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses) - = case @loc.attachItf @lhs.kind @lhs.fmtMode of - Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) - Right (code, defs, uses) -> (Seq.empty, code, defs, uses) - | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit - (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of - Left e -> (Seq.singleton e, empty, empty) - Right (pat,expr) -> (Seq.empty, pat, expr) - - lhs.sem_steps = let decl = case @lhs.kind of - VisitPure _ -> @loc.patPP >#< "=" >#< @loc.exprPP - VisitMonadic -> @loc.exprPP >#< ">>= \\" >#< @loc.patPP >#< "->" - in fmtDecl False @lhs.fmtMode decl - loc.convToMonad = case @loc.callKind of - VisitPure _ -> text "lift" - VisitMonadic -> empty - loc.callKind = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds - | Sim lhs.sem_steps = @steps.sem_steps - | PureGroup lhs.sem_steps = case @lhs.fmtMode of - FormatDo -> "let" >#< @steps.sem_steps -- formatted as a let-block (not a line-let) - _ -> @steps.sem_steps - --- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing --- declarations, because that determines how we need to wrap declarations --- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo -ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ] -SEM Visit | Visit - steps.fmtMode = case @kind of - VisitPure False -> FormatLetDecl - VisitPure True -> FormatLetLine - VisitMonadic -> FormatDo - -SEM VisitStep | PureGroup - steps.fmtMode = case @lhs.fmtMode of - FormatDo -> FormatLetDecl - mode -> mode - -{ -parResultName :: String -parResultName = "__outcome_" - -fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc -fmtDecl declPure fmt decl = case fmt of - FormatLetDecl -> pp decl - FormatLetLine -> "let" >#< decl >#< "in" - FormatDo | declPure -> "let" >#< decl >#< "in" - | otherwise -> pp decl -} - --- --- Some properties of VisitStep(s) --- - --- Used arguments -ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ] -SEM ERule - | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs - -SEM EChild - | EChild +usedArgs = \s -> case @kind of - ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s - _ -> s - - --- Number of steps in a 'Sim' block -ATTR VisitSteps [ | | size : Int ] -SEM VisitSteps - | Nil lhs.size = 0 - | Cons lhs.size = 1 + @tl.size - --- Number the steps in a 'Sim' block -ATTR VisitSteps VisitStep [ | index : Int | ] -SEM VisitSteps | Cons - hd.index = @lhs.index -- copy rule - tl.index = 1 + @lhs.index - lhs.index = @tl.index -- copy rule -SEM Visit | Visit steps.index = 0 -SEM VisitStep | Sim steps.index = 0 - lhs.index = @lhs.index -- needed for if we ever allow nested Sims - --- Is this the last step? -ATTR VisitSteps VisitStep [ | | isLast : Bool ] -ATTR VisitStep [ isLast : Bool | | ] -SEM VisitSteps - | Nil lhs.isLast = True - | Cons lhs.isLast = False - hd.isLast = @tl.isLast - -SEM VisitStep | Sim - loc.isMonadic = case @lhs.kind of - VisitMonadic -> True - _ -> False - - --- Child introduction -ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ] - -ATTR Visits Visit - VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ] - -SEM EProduction - | EProduction visits.childintros = @children.childintros - -SEM EChild - | ETerm lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty)) - | EChild lhs.childintros = Map.singleton @name @loc.introcode - loc.isDefor = case @tp of - NT _ _ defor -> defor - _ -> False - loc.valcode = case @kind of - ChildSyntax -> "arg_" >|< @name >|< "_" - ChildAttr -> -- decide if we need to invoke the sem-function under the hood - let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options -- when sepsemmods is not enabled, the indirection can be optimized away - then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr - else "sem_" >|< @loc.nt - | otherwise = empty -- no need to intro a terminal - in pp_parens (prefix >#< instname @name) - ChildReplace _ -> -- the higher-order attribute is actually a function that transforms - -- the semantics of the child (always deforested) - pp_parens (instname @name >#< @name >|< "_") - loc.aroundcode = if @hasAround - then locname @lhs.options @name >|< "_around" - else empty - loc.introcode = \kind fmtMode -> - let pat = text $ stname @name @loc.initSt - patStrict = @loc.addbang pat - attach = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode) - runAttach = unMon @lhs.options >#< pp_parens attach - decl = case kind of - VisitPure False -> pat >#< "=" >#< runAttach - VisitPure True -> patStrict >#< "=" >#< runAttach - VisitMonadic -> attach >#< ">>= \\" >#< patStrict >#< "->" - in if compatibleAttach kind @loc.nt @lhs.options - then Right ( fmtDecl False fmtMode decl - , Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro - , case @kind of -- variables used by the child introduction - ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr - ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options) - then id -- the sem dictionary attr is not used - else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) - ) $ - ( if @hasAround - then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing - else id - ) $ Map.empty - ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function - ChildSyntax -> Map.empty - ) - else Left $ IncompatibleAttachKind @name kind - loc.nt = extractNonterminal @tp - -{ -stname :: Identifier -> Int -> String -stname child st = "st_" ++ getName child ++ "X" ++ show st - --- should actually return some conversion info -compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool -compatibleAttach _ _ _ = True - -unMon :: Options -> PP_Doc -unMon options - | parallelInvoke options = text "'System.IO.Unsafe'.unsafePerformIO" -- IO monad - | otherwise = text "'Control.Monad.Identity'.runIdentity" -- identity monad -} - --- rules -ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc} - mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ] - -SEM ERule | ERule - lhs.sem_rules = if @loc.used == 0 - then empty - else @loc.rulecode - loc.rulecode = ( if @loc.genpragma - then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of - -- type errors in the rule. It will definitely not be precise, and may take some additional - -- source space, but let's see if it's worth it in practice. - else empty - ) - >-< @loc.lambda - >-< indent ((column @rhs.pos - 2) `max` 2) - ( if @loc.genpragma - then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma - else @rhs.semfunc - ) - loc.pragma = "/*# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#*/" - loc.endpragma = ppWithLineNr (\ln -> "/*# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#*/") - loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos - loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos)) - - -- This comment describes the Haskell rationale for lambdas - -- we generate a simple pattern binding because of overloading-resolving during the type inference process. - -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context). - -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have - -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead - -- of a function definition. - -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures - -- but are lambda-lifted instead. - -- loc.lambda = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->" - - -- For Clean, we do not want to generate lambdas, but functions instead - loc.lambda = @name >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "=" - - loc.argPats = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str - | otherwise = @loc.addbang1 (pp str) - in case mbAttr of - Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> - case Map.lookup nm @lhs.localAttrTypes of - Just tp -> pp_parens (pp_parens match) -- TODO Remove? >#< "::" >#< ppTp tp) - Nothing -> match - Just attr | not (noPerRuleTypeSigs @lhs.options) -> - case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of - Just tpDoc -> pp_parens (pp_parens match) -- TODO Remove? >#< "::" >#< tpDoc) - Nothing -> match - _ -> match - | (str,mbAttr) <- Map.assocs @rhs.attrs - ] - loc.argExprs = ppSpaced [ case mbAttr of - Nothing -> "arg_" >|< str - _ -> text str - | (str,mbAttr) <- Map.assocs @rhs.attrs - ] - loc.stepcode = \kind fmtMode -> if kind `compatibleRule` @pure - then Right $ let oper | @pure = "=" - | otherwise = "<-" -- TODO Desugar - decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs) - tp = if @pure && not (noPerRuleTypeSigs @lhs.options) - then @pattern.attrTypes - else empty - in fmtDecl @pure fmtMode (tp >-< decl) - else Left $ IncompatibleRuleKind @name kind - - lhs.mrules = Map.singleton @name @loc.stepcode - -ATTR Expression [ | | tks : {[HsToken]} ] -SEM Expression - | Expression lhs.tks = @tks - -{ -dummyPat :: Options -> Bool -> PP_Doc -dummyPat opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = if strictDummyToken opts - then text "Void" - else text "(_)" - | otherwise = let match | strictDummyToken opts = "!_" - | otherwise = "_" - in pp_parens (match >#< "::" >#< dummyType opts noArgs) - where match | strictDummyToken opts = "(!_)" - | otherwise = "_" - -dummyArg :: Options -> Bool -> PP_Doc -dummyArg opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = text "Void" - | otherwise = text "GHC.Prim.realWorld#" - -dummyType :: Options -> Bool -> PP_Doc -dummyType opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = text "Void" - | otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)" -} - -{ --- rules are "deinlined" to prevent needless code duplication. --- if there is only a bit of duplication, we allow ghc to decide if it is worth it. --- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it. -ruleInlineThresholdSoft :: Int -ruleInlineThresholdSoft = 3 - -ruleInlineThresholdHard :: Int -ruleInlineThresholdHard = 5 - -reallyOftenUsedThreshold :: Int -reallyOftenUsedThreshold = 12 -} - -ATTR Expression [ | | pos : {Pos} ] -SEM Expression | Expression lhs.pos = @pos - --- pattern and expression semantics -ATTR Pattern [ | | sem_lhs : { PP_Doc } ] -ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ] -ATTR Pattern Patterns [ | | ] - -SEM Pattern - | Alias loc.varPat = text $ attrname @lhs.options False @field @attr - loc.patExpr = if @pat.isUnderscore - then @loc.varPat - else @loc.varPat >|< "@" >|< @pat.sem_lhs - lhs.sem_lhs = @loc.addbang1 @loc.patExpr - | Product lhs.sem_lhs = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs - | Constr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs - | Underscore lhs.sem_lhs = text "_" - | Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs - --- Check if a pattern is just an underscore -ATTR Pattern [ | | isUnderscore:{Bool}] -SEM Pattern - | Constr lhs.isUnderscore = False - | Product lhs.isUnderscore = False - | Alias lhs.isUnderscore = False - | Underscore lhs.isUnderscore = True - --- Collect the attributes defined by a pattern -ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ] -SEM Pattern | Alias - lhs.attrs = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs - --- All attribute types of this pattern -ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ] -SEM Pattern | Alias - loc.mbTp = if @field == _LHS - then Map.lookup @attr @lhs.synmap - else if @field == _LOC - then Map.lookup @attr @lhs.localAttrTypes - else Nothing - lhs.attrTypes = empty -- Don't generate these type signatures; increases performance in Clean - -- maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp - -- >-< @pat.attrTypes - --- Collect the attributes used by the right-hand side -ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] -SEM HsToken - | AGLocal lhs.attrs = Map.singleton (fieldname @var) Nothing - | AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST' - then Nothing -- should not be used in the first place - else Just $ mkNonLocalAttr (@field == _LHS) @field @attr - lhs.attrs = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr - -{ -data NonLocalAttr - = AttrInh Identifier Identifier - | AttrSyn Identifier Identifier deriving Show - -mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr -mkNonLocalAttr True = AttrInh -- True: inherited attr -mkNonLocalAttr False = AttrSyn - -lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs -lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns - --- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that --- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. --- However, for now we simply decide to return Nothing in this case, which skips the type annotation. -lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupType child name attrMp childMp - | noParameters childTp = Just ppDoc - | otherwise = Nothing - where - attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs - childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp - nonterm = extractNonterminal childTp - childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp - ppDoc = ppTp attrTp - -noParameters :: Type -> Bool -noParameters (Haskell _) = True -noParameters (NT _ args _) = null args -} - -ATTR Expression [ | | semfunc : {PP_Doc} ] - -SEM Expression - | Expression lhs.attrs = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks - lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks - loc.inhhstoken = Inh_HsToken @lhs.options - --- child visit map -ATTR Visit - Visits - EProduction - EProductions - ENonterminal - ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} - | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ] - -ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.allchildvisit = @nonts.childvisit - -SEM Visit - | Visit - loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits - lhs.childvisit = Map.singleton @ident @loc.invokecode - loc.invokecode = \chn kind -> -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit - if kind `compatibleKind` @kind - then Right $ - let pat | isLazyKind @kind = pat0 - | otherwise = @loc.addbang pat0 - pat0 = pp_parens pat1 - pat1 = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname @lhs.options True chn) $ Set.toList @syn) - >#< cont - cont = case @loc.nextVisitInfo of - NoneVis -> empty - _ -> ch1 - ch0 = text $ stname chn @from - ch1 = text $ stname chn @to - expr = case (kind, @kind) of - (VisitPure _, VisitPure _) -> expr0 - (VisitPure _, VisitMonadic) -> unMon @lhs.options >#< expr0 - (VisitMonadic, VisitPure _) -> "lift" >#< expr0 - (VisitMonadic, VisitMonadic) -> expr0 - expr0 = case @loc.prevVisitInfo of - NoneVis -> error "error: invocation of a visit from a state that has no next visits" - OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args - ManyVis -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 - >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args - args = pp_parens args0 >#< args1 - args0 = @loc.nameTIn_visit >#< @loc.inhargs chn - args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True - | otherwise = empty - in (pat, expr) -- pretty print of the pattern and the expression part - else Left $ IncompatibleVisitKind chn @ident kind @kind - -{ --- a `compatibleKind` b means: can kind b be invoked from a -compatibleKind :: VisitKind -> VisitKind -> Bool -compatibleKind _ _ = True - -compatibleRule :: VisitKind -> Bool -> Bool -compatibleRule (VisitPure _) False = False -compatibleRule _ _ = True -} - -------------------------------------------------------------------------------- --- Properties of rules -------------------------------------------------------------------------------- - --- Construct an environment that counts how often certain rules are used -ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ] -ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ] - -SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage -SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1 -SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo - -{ -unionWithSum = Map.unionWith (+) -} - --- Collect in what visit-kinds a rule is used -ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ] -SEM VisitStep | Sem - lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind) - -ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ] -SEM EProduction | EProduction - rules.ruleKinds = @visits.ruleKinds - -SEM ERule | ERule - loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds - loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds - -ATTR Pattern Patterns [ anyLazyKind : Bool | | ] - - -------------------------------------------------------------------------------- --- Intra attributes -------------------------------------------------------------------------------- -{ -uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) -uwSetUnion = Map.unionWith Set.union - -uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) -uwMapUnion = Map.unionWith Map.union -} -ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} - | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ] - -ATTR Visit Visits [ terminaldefs : {Set String} | | ] -ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ] - -SEM EChild | ETerm - lhs.terminaldefs = Set.singleton $ fieldname @name - -SEM EProduction | EProduction - visits.allintramap = @visits.intramap - visits.terminaldefs = @children.terminaldefs - -SEM Visit - | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap - lhs.intramap = Map.singleton @from @loc.thisintra - loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap - loc.uses = let mp1 = @steps.uses - mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ] - in mp1 `Map.union` mp2 - loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh - loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs - loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ] - -ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)} - ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ] -ATTR Visit Visits - VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)} - ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ] - -SEM ERule - | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs - lhs.ruleuses = Map.singleton @name @rhs.attrs - -SEM EProduction - | EProduction visits.ruledefs = @rules.ruledefs - visits.ruleuses = @rules.ruleuses - -ATTR Visit Visits - EProduction - EProductions - ENonterminal - ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} - visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ] - -SEM Visit - | Visit lhs.visitdefs = Map.singleton @ident @syn - lhs.visituses = Map.singleton @ident @inh - -ATTR Visit Visits - VisitSteps VisitStep - EProduction EProductions - ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)} - avisituses : {Map VisitIdentifier (Set Identifier)} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs - nonts.avisituses = @nonts.visituses - -ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String} - uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] -SEM VisitStep - | Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs - lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses - | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs - lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ] - in Map.insert (stname @child @from) Nothing $ convert $ - maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses - -------------------------------------------------------------------------------- --- Identification of lazy intra defs within a production --- --- These identifiers will not be marked as strict in rules and state closures -------------------------------------------------------------------------------- - -ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ] -ATTR ERules ERule [ lazyIntras : {Set String} | | ] - -SEM Visit | Visit - loc.lazyIntrasInh = case @kind of - VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs - _ -> Set.empty - lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras - -SEM VisitStep | PureGroup - lhs.lazyIntras = if @ordered - then @steps.lazyIntras - else @steps.defs - -SEM EProduction | EProduction - loc.lazyIntras = @visits.lazyIntras - -------------------------------------------------------------------------------- --- Pretty printing of haskell code -------------------------------------------------------------------------------- - -SEM HsTokens [ || tks : {[(Pos,String)]} ] - | Cons lhs.tks = @hd.tok : @tl.tks - | Nil lhs.tks = [] - -SEM HsToken - | AGLocal loc.tok = (@pos,fieldname @var) - -SEM HsToken [ || tok:{(Pos,String)}] - | AGField - loc.addTrace = case @rdesc of - Just d -> \x -> "(trace_n " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))" - Nothing -> id - lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr) - - | HsToken lhs.tok = (@pos, @value) - - | CharToken lhs.tok = (@pos, if null @value - then "" - else showCharShort (head @value) - ) - - | StrToken lhs.tok = (@pos, showStrShort @value) - | Err lhs.tok = (@pos, "") - -------------------------------------------------------------------------------- --- Alternative code generation (sepsemmods) -------------------------------------------------------------------------------- - -ATTR ExecutionPlan [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc} - | | genIO : {IO ()} ] - -SEM ExecutionPlan - | ExecutionPlan lhs.genIO = do @loc.genMainModule - @loc.genCommonModule - @nonts.genProdIO - loc.mainModuleFile = @lhs.mainFile - loc.ppMonadImports = pp "import qualified Control.Monad.Identity" - loc.genMainModule = writeModule @loc.mainModuleFile - ( [ pp $ @lhs.iclModuleHeader @lhs.mainName "" "" False - , @loc.ppMonadImports - , pp $ "import " ++ @lhs.mainName ++ "_common" - ] - ++ @nonts.imports - ++ [@lhs.mainBlocksDoc] - ++ [@loc.wrappersExtra] - ++ @nonts.appendMain - ) - loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") - loc.genCommonModule = writeModule @loc.commonFile - ( [ pp $ @lhs.iclModuleHeader @lhs.mainName "_common" "" True - , @loc.ppMonadImports - , @lhs.importBlocks - , @lhs.textBlocks - , @loc.commonExtra - ] - ++ @nonts.appendCommon - ) - -ATTR ENonterminal [ | | appendCommon, appendMain : { PP_Doc } ] -ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ] - -SEM ENonterminal - | ENonterminal lhs.appendMain = (if @nt `Set.member` @lhs.wrappers - then @loc.wr_inh_icl - >-< @loc.wr_syn_icl - >-< @loc.wrapper_icl - else empty) - >-< @loc.sem_nt - lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty) - >-< @loc.t_init_icl - >-< @loc.t_states_icl - >-< @loc.k_states - >-< @prods.t_visits - -ATTR EProduction EProductions - ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]} - genProdIO USE {>>} {return ()} : {IO ()} ] - -SEM EProduction - | EProduction lhs.imports = [pp $ "import " ++ @loc.moduleName] - loc.moduleName = @lhs.mainName ++ @loc.suffix - loc.suffix = '_' : show @lhs.nt ++ ('_' : show @con) - loc.outputfile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix) - loc.ppMonadImports = pp "import qualified Control.Monad.Identity" - lhs.genProdIO = writeModule @loc.outputfile - [ pp $ @lhs.iclModuleHeader @lhs.mainName @loc.suffix @loc.semname True - , @lhs.importBlocks - , @loc.ppMonadImports - , pp $ "import " ++ @lhs.mainName ++ "_common" - , @loc.sem_prod - ] - -{ -renderDocs :: [PP_Doc] -> String -renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" - -writeModule :: FilePath -> [PP_Doc] -> IO () -writeModule path docs - = do bExists <- doesFileExist path - if bExists - then do input <- readFile path - seq (length input) (return ()) - if input /= output - then dumpIt - else return () - else dumpIt - where - output = renderDocs docs - dumpIt = writeFile path output - -cleanIclModuleHeader :: Options -> String -> String -cleanIclModuleHeader flags input - = case moduleName flags - of Name nm -> genMod nm - Default -> genMod (defaultModuleName input) - NoName -> "" - where genMod x = "implementation module " ++ x - -cleanDclModuleHeader :: Options -> String -> Maybe String -> String -cleanDclModuleHeader flags input export - = case moduleName flags - of Name nm -> genMod nm - Default -> genMod (defaultModuleName input) - NoName -> "" - where genMod x = "definition module " ++ x ++ genExp export x - genExp Nothing _ = "" - genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")" - -defaultModuleName :: String -> String -defaultModuleName = dropExtension - -mkIclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String -mkIclModuleHeader Nothing defaultName suffix _ _ - = "implementation module " ++ defaultName ++ suffix -mkIclModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports - = "implementation module " ++ name ++ suffix ++ "\n" ++ imports ++ "\n" - -mkDclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String -mkDclModuleHeader Nothing defaultName suffix _ _ - = "definition module " ++ defaultName ++ suffix -mkDclModuleHeader (Just (name, exports, _)) _ suffix addExports replaceExports - = "definition module " ++ name ++ suffix ++ ex ++ "\n" - where - ex = if null exports || (replaceExports && null addExports) - then "" - else if null addExports - then exports - else if replaceExports - then addExports - else exports ++ "," ++ addExports -} - - --- --- Bang pattern usage --- - -SEM ERule | ERule loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM Visit | Visit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM ENonterminal | ENonterminal loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM EProduction | EProduction loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM EChild | EChild loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM EChild | ETerm loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM VisitStep | ChildVisit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM Pattern | Alias Constr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x - -SEM Visit | Visit loc.addbang1 = if isLazyKind @kind then id else @loc.addbang -SEM ENonterminal | ENonterminal loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id -SEM ERule | ERule loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang -SEM Pattern | Alias Constr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang - --- --- Distribute single-visit-next map downward --- - -ATTR EProductions EProduction Visits Visit - [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ] - -SEM ENonterminal | ENonterminal - prods.nextVisits = @nextVisits - prods.prevVisits = @prevVisits - --- --- Collect and distribute the from/to states of a visit --- - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit - [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ] - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep - [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ] - -SEM Visit | Visit - lhs.fromToStates = Map.singleton @ident (@from, @to) - -SEM ExecutionPlan | ExecutionPlan - nonts.allFromToStates = @nonts.fromToStates - -SEM VisitStep | ChildVisit - (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates - - --- --- Collect and distribute the actual types of children of productions --- - -ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ] -ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ] - -SEM EProduction | EProduction - loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes - -SEM EChild | EChild ETerm - lhs.childTypes = Map.singleton @name @tp - --- --- Distribute types of local attributes --- - -ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ] -ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ] -ATTR ERules ERule Pattern Patterns [ localAttrTypes : {Map Identifier Type} | | ] - -SEM ENonterminal | ENonterminal - prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes - -SEM EProduction | EProduction - loc.localAttrTypes = Map.findWithDefault Map.empty @con @lhs.localAttrTypes - --- --- Collect and distribute visit kinds --- - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep - [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ] - -SEM Visit | Visit - lhs.visitKinds = Map.singleton @ident @kind - -SEM ExecutionPlan | ExecutionPlan - nonts.allVisitKinds = @nonts.visitKinds - --- --- Collect and distribute the initial state of nonterminals --- - -ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ] -ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep - [ allInitStates : {Map NontermIdent Int} | | ] - -SEM ENonterminal | ENonterminal - lhs.initStates = Map.singleton @nt @initial - -SEM ExecutionPlan | ExecutionPlan - nonts.allInitStates = @nonts.initStates - -SEM EChild | EChild - loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates - --- --- Push the nonterminal type downward --- - -ATTR EProductions EProduction [ ntType : Type | | ] -SEM ENonterminal | ENonterminal - loc.ntType = NT @nt (map show @params) False - --- --- Collect errors contained in rules that should be yielded when the --- rules are scheduled. --- - -ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] -SEM ERule | ERule - lhs.errors = case @mbError of - Just e | @loc.used > 0 -> Seq.singleton e - _ -> Seq.empty - +INCLUDE "ExecutionPlan.ag" +INCLUDE "Patterns.ag" +INCLUDE "Expression.ag" +INCLUDE "HsToken.ag" + +imports +{ +import ExecutionPlan +import Pretty +import PPUtil +import Options +import Data.Monoid(mappend,mempty) +import Data.Maybe +import Debug.Trace +import System.IO +import System.Directory +import System.FilePath +import UU.Scanner.Position + +import TokenDef +import HsToken +import ErrorMessages + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Sequence(Seq) +import qualified Data.Sequence as Seq +import Data.Foldable(toList) +} + +ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild + [ importBlocks : PP_Doc + textBlocks : PP_Doc + iclModuleHeader : {String -> String -> String -> Bool -> String} + dclModuleHeader : {String -> String -> String -> Bool -> String} + mainFile : String + mainName : String + constructorTypeMap : {Map NontermIdent ConstructorType} | | ] + +------------------------------------------------------------------------------- +-- Options +------------------------------------------------------------------------------- +ATTR ExecutionPlan + ENonterminals ENonterminal + EProductions EProduction + ERules ERule + EChildren EChild + Expression + HsToken HsTokens HsTokensRoot + Pattern Patterns + Visits Visit + VisitSteps VisitStep [ options : {Options} | | ] +ATTR EProductions EProduction [ rename : {Bool} | | ] + +SEM ENonterminal + | ENonterminal prods.rename = rename @lhs.options + +------------------------------------------------------------------------------- +-- Context info (nonterminal ident, constructor ident, nonterm params, etc.) +------------------------------------------------------------------------------- + +ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ] +SEM ENonterminal + | ENonterminal prods.nt = @nt + +ATTR EChildren EChild ERules ERule Visits Visit + [ con : ConstructorIdent | | ] + +SEM EProduction + | EProduction children.con = @con + rules.con = @con + visits.con = @con + +ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ] +SEM ENonterminal | ENonterminal + prods.params = @params + +ATTR EProductions EProduction [ classCtxs : ClassContext | | ] +SEM ENonterminal | ENonterminal + prods.classCtxs = @classCtxs + +------------------------------------------------------------------------------- +-- Default output +------------------------------------------------------------------------------- +ATTR ExecutionPlan [ | | output : {PP_Doc} + output_dcl : {PP_Doc} ] + +SEM ExecutionPlan + | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra + lhs.output_dcl = @nonts.output_dcl + +ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent} + | | output USE {>-<} {empty} : {PP_Doc} + output_dcl USE {>-<} {empty} : {PP_Doc}] + +SEM ExecutionPlan + | ExecutionPlan nonts.wrappers = @wrappers + +SEM ENonterminal + | ENonterminal lhs.output = ("// " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-') + >-< (if @loc.hasWrapper + then "// wrapper" + >-< @loc.wr_inh_icl + >-< @loc.wr_syn_icl + >-< @loc.wrapper_icl + >-< "" + else empty) + >-< (if folds @lhs.options + then "// cata" + >-< @loc.sem_nt + >-< "" + else empty) + >-< (if semfuns @lhs.options + then "// semantic domain" + >-< @loc.t_init_icl + >-< @loc.t_states_icl + >-< @loc.k_states + >-< @prods.sem_prod + >-< "" + else empty) + loc.hasWrapper = @nt `Set.member` @lhs.wrappers + + lhs.output_dcl = ("// " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-') + >-< (if dataTypes @lhs.options + then "// data" + >-< @loc.datatype + >-< "" + else empty) + >-< (if @loc.hasWrapper + then "// wrapper" + >-< @loc.wr_inh_dcl + >-< @loc.wr_syn_dcl + >-< @loc.wrapper_dcl + >-< "" + else empty) + >-< (if folds @lhs.options + then "// cata" + >-< @loc.semname >#< "::" >#< @loc.sem_tp + >-< "" + else empty) + >-< (if semfuns @lhs.options + then "// semantic domain" + >-< @loc.t_init_dcl + >-< @loc.t_states_dcl + >-< @prods.t_visits + >-< @prods.sem_prod_tys + >-< "" + else empty) + +------------------------------------------------------------------------------- +-- Nonterminal datatype +------------------------------------------------------------------------------- +ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} + derivings : {Derivings} | | ] + +SEM ExecutionPlan + | ExecutionPlan nonts.typeSyns = @typeSyns + nonts.derivings = @derivings + +SEM ENonterminal + | ENonterminal loc.classPP = ppClasses $ classCtxsToDocs @classCtxs + loc.aliasPre = "::" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< ":==" + loc.datatype = case lookup @nt @lhs.typeSyns of + Nothing -> "::" >#< @loc.classPP >#< @nt >#< @loc.t_params + >-< ( if null @prods.datatype + then empty + else if isRecordConstructor @nt @lhs.constructorTypeMap + then indent 2 $ "=" >#< @prods.recordtype + else indent 2 $ vlist $ ( ("=" >#< head @prods.datatype) + : (map ("|" >#<) $ tail @prods.datatype)) + ) + >-< indent 2 @loc.derivings + Just (List t) -> @loc.aliasPre >#< "[" >#< show t >#< "]" + Just (Maybe t) -> @loc.aliasPre >#< "Data.Maybe" >#< pp_parens (show t) + Just (Tuple ts) -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts) + Just (Either l r) -> @loc.aliasPre >#< "Data.Either" >#< pp_parens (show l) >#< pp_parens (show r) + Just (Map k v) -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v) + Just (IntMap t) -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t) + Just (OrdSet t) -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (show t) + Just IntSet -> @loc.aliasPre >#< "Data.IntSet.IntSet" +-- Just x -> error $ "Type " ++ show x ++ " is not supported" + loc.derivings = case Map.lookup @nt @lhs.derivings of + Nothing -> empty + Just s -> if Set.null s + then empty + else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s) + +{ +classCtxsToDocs :: ClassContext -> [PP_Doc] +classCtxsToDocs = map toDoc where + toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args)) + +classConstrsToDocs :: [Type] -> [PP_Doc] +classConstrsToDocs = map ppTp + +ppClasses :: [PP_Doc] -> PP_Doc +ppClasses [] = empty +ppClasses xs = "|" >#< pp_block "" "" "&" xs + +ppQuants :: [Identifier] -> PP_Doc +ppQuants [] = empty +ppQuants ps = "E." >#< ppSpaced ps >#< ":" +} + +ATTR EProduction [ | | datatype : {PP_Doc} + recordtype : {PP_Doc} ] +ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} + recordtype : {PP_Doc} ] + +-- we generate the data type in the type-class style instead of the GADT style +-- the GADT extension may be required if equality constraints are used +SEM EProduction + | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1 + >#< conname @lhs.rename @lhs.nt @con + >#< ppConFields (dataRecords @lhs.options) @children.datatype + lhs.recordtype = @loc.quantPP1 >#< @loc.classPP1 + >#< ppConFields True @children.recordtype + loc.classPP1 = ppClasses (classConstrsToDocs @constraints) + loc.quantPP1 = ppQuants @params + +SEM EProductions + | Cons lhs.recordtype = @hd.recordtype + | Nil lhs.recordtype = empty + +{ +-- first parameter indicates: generate a record or not +ppConFields :: Bool -> [PP_Doc] -> PP_Doc +ppConFields True flds = ppListSep "{" "}" ", " flds +ppConFields False flds = ppSpaced flds +} + + +ATTR EChild [ | | datatype : {PP_Doc} + recordtype : {PP_Doc} ] +ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]} + recordtype USE {:} {[]} : {[PP_Doc]} ] + +-- Note: the child may be a higher-order attribute, and its semantics may be deforested +SEM EChild + | EChild ETerm + loc.tpDoc = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp + loc.strNm = recordFieldname @lhs.nt @lhs.con @name + loc.field = if dataRecords @lhs.options + then @loc.strNm >#< "::" >#< @loc.tpDoc + else @loc.tpDoc + loc.recordfield = @loc.strNm >#< "::" >#< @loc.tpDoc + loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x + | EChild lhs.datatype = case @kind of + ChildAttr -> empty -- higher order attributes are not part of the data type + _ -> @loc.field + + lhs.recordtype = case @kind of + ChildAttr -> empty -- higher order attributes are not part of the data type + _ -> @loc.recordfield + | ETerm lhs.datatype = @loc.field + lhs.recordtype = @loc.recordfield + +{ +ppTp :: Type -> PP_Doc +ppTp = text . typeToHaskellString Nothing [] +} + +------------------------------------------------------------------------------- +-- Nonterminal semantic function +------------------------------------------------------------------------------- +SEM ENonterminal + | ENonterminal loc.fsemname = \x -> "sem_" ++ show x + loc.semname = @loc.fsemname @nt + loc.frecarg = \t x -> case t of + NT nt _ _ -> pp_parens (@fsemname nt >#< x) + _ -> pp x + + -- The sem_NT function is lazy in the AST: it depends on the application of "child" + -- rules to which extend the AST needs to be constructed. + loc.sem_tp = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params + loc.quantPP = ppQuants @params + + loc.sem_nt = @loc.semname >#< "::" >#< @loc.sem_tp + >-< case lookup @nt @lhs.typeSyns of + Nothing -> @prods.sem_nt + Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Cons" + >#< @loc.semname >|< "_Nil" + >#< case t of + NT nt _ _ -> pp_parens ("map" >#< @fsemname nt >#< "list") + _ -> pp "list" + Just (Maybe t) -> @loc.semname >#< "'Data.Maybe'.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing" + >-< @loc.semname >#< pp_parens ("'Data.Maybe'.Just just") >#< "=" + >#< @loc.semname >|< "_Just" >#< @frecarg t "just" + Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "=" + >#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts) + Just (Either l r) -> @loc.semname >#< "('Data.Either'.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left" + >-< @loc.semname >#< "('Data.Either'.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right" + Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "'Data.Map'.foldrWithKey" + >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" + >#< case v of + NT nt _ _ -> pp_parens ("'Data.Map'.map" >#< @fsemname nt >#< "m") + _ -> pp "m" + Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "'Data.IntMap'.foldWithKey" + >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" + >#< case v of + NT nt _ _ -> pp_parens ("'Data.IntMap'.map" >#< @fsemname nt >#< "m") + _ -> pp "m" + Just (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Entry" + >#< @loc.semname >|< "_Nil" + >#< pp_parens ( + ( case t of + NT nt _ _ -> pp_parens ("map" >#< @fsemname nt) + _ -> empty + ) >#< pp_parens ("'Data.IntSet'.elems" >#< "s") + ) + Just IntSet -> @loc.semname >#< "s" >#< "=" >#< "foldr" >#< @loc.semname >|< "_Entry" + >#< @loc.semname >|< "_Nil" + >#< pp_parens ("'Data.IntSet'.elems" >#< "s") +-- Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns + +-- The number of productions +ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ] +SEM EProduction | EProduction lhs.count = {1} + +-- The per-production cases for the sem_NT function +ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ] +SEM EProduction + | EProduction lhs.sem_nt = let lhs = "sem_" >|< @lhs.nt + rhs = "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw + cnnm = conname @lhs.rename @lhs.nt @con + in if isRecordConstructor @lhs.nt @lhs.constructorTypeMap + then lhs >#< "{" >#< cnnm >#< "|" >#< + pp_block "" "" "," (zipWith (\l r -> l >#< "=" >#< r) @children.recfields @children.argpats) >#< "}" >#< rhs + else lhs >#< "(" >#< cnnm >#< ppSpaced @children.argpats >#< ")" >#< rhs + +{ +isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool +isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor +} + +ATTR EChild [ | | argnamesw : { PP_Doc } ] +ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ] + +SEM EChild + | EChild lhs.argnamesw = case @kind of + ChildSyntax -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")" + ChildAttr -> empty -- no sem-case for a higher-order child + ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")" + | ETerm lhs.argnamesw = text $ fieldname @name + +------------------------------------------------------------------------------- +-- Types of attributes +------------------------------------------------------------------------------- +ATTR ExecutionPlan + ENonterminals + ENonterminal [ inhmap : {Map NontermIdent Attributes} + synmap : {Map NontermIdent Attributes} | | ] + +ATTR EProductions EProduction + ERules ERule + Patterns Pattern + Visits + Visit [ inhmap : {Attributes} + synmap : {Attributes} + allInhmap : {Map NontermIdent Attributes} + allSynmap : {Map NontermIdent Attributes} | | ] + +SEM ENonterminal + | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap + (Just prods.synmap) = Map.lookup @nt @lhs.synmap + prods.allInhmap = @lhs.inhmap + prods.allSynmap = @lhs.synmap + +------------------------------------------------------------------------------- +-- State datatypes +------------------------------------------------------------------------------- +{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)} + +ATTR Visit [ | | allvisits : { VisitStateState }] +ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}] +ATTR EProduction + EProductions [ | | allvisits: {[VisitStateState]}] + +SEM Visit + | Visit lhs.allvisits = (@ident, @from, @to) + +SEM EProductions + | Cons lhs.allvisits = @hd.allvisits -- just pick the first production + | Nil lhs.allvisits = error "Every nonterminal should have at least 1 production" + +-- type of tree in a given state s +SEM ENonterminal + | ENonterminal loc.outedges = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits + loc.inedges = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits + loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges + loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits + loc.t_type = "T_" >|< @nt + loc.lt_type = "t_" >|< @nt + loc.t_params = ppSpaced @params + loc.t_init_icl = @loc.t_init_dcl >-< + "attach_" >|< @loc.t_type >#< pp_parens (@loc.t_type >#< @loc.lt_type) >#< "=" >#< @loc.lt_type + loc.t_init_dcl = "::" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type + >#< + pp_parens ( + ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params)) + loc.t_states_icl = vlist $ map (\st -> + let nt_st = @nt >|< "_s" >|< st + c_st = "C_" >|< nt_st + inv_st = "inv_" >|< nt_st + nextVisit = Map.findWithDefault ManyVis st @nextVisits + in case nextVisit of + NoneVis -> empty -- empty semantics + OneVis vId -> inv_st >#< pp_parens (c_st >#< "x") >#< "=" >#< "x" + ManyVis -> empty + ) $ Set.toList @loc.allstates + loc.t_states_dcl = vlist $ map (\st -> + let nt_st = @nt >|< "_s" >|< st + t_st = "T_" >|< nt_st + k_st = "K_" >|< nt_st + c_st = "C_" >|< nt_st + inv_st = "inv_" >|< nt_st + nextVisit = Map.findWithDefault ManyVis st @nextVisits + in case nextVisit of + NoneVis -> "::" >#< t_st >#< @loc.t_params >#< "=" >#< c_st -- empty semantics + OneVis vId -> "::" >#< t_st >#< @loc.t_params >#< "=" >#< c_st >#< (pp_parens (conNmTVisit @nt vId >#< @loc.t_params)) + ManyVis -> "::" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::" -- TODO : Cleanify + >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("E.t:" >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t")) + >#< "->" >#< t_st >#< @loc.t_params -- this is a conventional data type, but declared with GADT syntax + ) $ Set.toList @loc.allstates + +-- type of a key which identifies a visit v from state s +SEM ENonterminal + | ENonterminal loc.k_type = "K_" ++ show @nt + loc.k_states = vlist $ map (\st -> + let nt_st = @nt >|< "_s" >|< st + k_st = "K_" >|< nt_st + outg = filter (\(v,f,t) -> f == st) @prods.allvisits + visitlist = vlist $ map (\(v,f,t) -> + @loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params) + ) outg + nextVisit = Map.findWithDefault ManyVis st @nextVisits + decl = "::" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist + in case nextVisit of + NoneVis -> empty + OneVis _ -> empty + ManyVis -> decl + ) $ Set.toList @loc.allstates + +-- type of a visit v, with continuation as new state s +ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ] + +SEM EProductions + | Cons lhs.t_visits = @hd.t_visits -- just pick the first production + +SEM Visit + | Visit loc.nameT_visit = conNmTVisit @lhs.nt @ident + loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident + loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident + loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to + + loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state? + loc.typecon = case @kind of + VisitPure _ -> empty + VisitMonadic -> ppMonadType @lhs.options + + loc.t_params = ppSpaced @lhs.params + lhs.t_visits = "::" >#< @loc.nameT_visit >#< @loc.t_params >#< ":==" >#< + pp_parens (@loc.nameTIn_visit >#< @loc.t_params) + >#< ( if dummyTokenVisit @lhs.options + then "->" >#< dummyType @lhs.options True -- Additional (unused though) argument + else empty + ) + >#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params) + >-< "::" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#< + @loc.inhpart + >-< "::" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#< + @loc.synpart >#< case @loc.nextVisitInfo of + NoneVis -> empty -- don't return a continuation at all + _ -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params) -- normal route: select the next semantics + + loc.inhpart = @loc.ppTypeList @inh @lhs.inhmap + loc.synpart = @loc.ppTypeList @syn @lhs.synmap + loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of + Just tp -> ppTp tp ) $ Set.toList s + +{ +conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId +conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId +conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId +conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId + +ppMonadType :: Options -> PP_Doc +ppMonadType opts + | parallelInvoke opts = text "IO" + | otherwise = text "Identity" +} + +------------------------------------------------------------------------------- +-- Inh and Syn wrappers +------------------------------------------------------------------------------- +SEM ENonterminal + | ENonterminal loc.wr_inh_icl = @loc.genwrap_icl "Inh" @loc.wr_inhs + loc.wr_syn_icl = @loc.genwrap_icl "Syn" @loc.wr_syns + loc.genwrap_icl = \nm attr -> + let tyConName = nm >|< "_" >|< @nt + in (let (d, _, _) = foldr (\(i, t) (d, c, n) -> (d >-< + i >|< "_" >|< tyConName >#< "::" >#< tyConName >#< "->" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t) + >-< i >|< "_" >|< tyConName >#< pp_parens (tyConName >#< unwords (replicate (n - c - 1) "_" ++ ["x"] ++ replicate c "_")) >#< "= x" + , c + 1, n) + ) (empty, 0, length attr) attr + in d) + loc.wr_inh_dcl = @loc.genwrap_dcl "Inh" @loc.wr_inhs + loc.wr_syn_dcl = @loc.genwrap_dcl "Syn" @loc.wr_syns + loc.genwrap_dcl = \nm attr -> + let tyConName = nm >|< "_" >|< @nt + in "::" >#< tyConName >#< @loc.t_params >#< "=" >#< tyConName -- >#< "{" + >#< (ppSpaced $ map (\(_,t) -> @loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t) attr) -- >#< "}" + >-< + (let (d, _, _) = foldr (\(i, t) (d, c, n) -> (d >-< + i >|< "_" >|< tyConName >#< "::" >#< tyConName >#< "->" >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t) + , c + 1, n) + ) (empty, 0, length attr) attr + in d) + loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap + loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.synAttrs + loc.wr_inhs1 = Map.toList @loc.synAttrs + loc.wr_filter = if lateHigherOrderBinding @lhs.options + then Map.delete idLateBindingAttr + else id + loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap + loc.inhlist = map (lhsname @lhs.options True . fst) @loc.wr_inhs + loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1 + loc.synlist = map (lhsname @lhs.options False . fst) @loc.wr_syns + loc.wrapname = "wrap_" ++ show @nt + loc.inhname = "Inh_" ++ show @nt + loc.synname = "Syn_" ++ show @nt + loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits + loc.wrapper_icl = (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params -- TODO : Remove ? >#< "->" + >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params)) + >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act")) + >#< (@loc.addbang $ pp_parens (@loc.inhname + >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "=")) + >-< + indent 3 (case @initialv of + -- case where there are no inherited or synthesized attributes + [] -> text @loc.synname -- TODO : Remove? >#< " { }" + (initv:_) -> -- TODO: take care of multiple visits + let inCon = conNmTVisitIn @nt initv + outCon = conNmTVisitOut @nt initv + pat = @loc.addbang $ pp_parens $ pat0 + pat0 = outCon >#< ppSpaced @loc.synlist -- should be an "end" state, thus no continuation expected here + arg = inCon >#< ppSpaced @loc.inhlist1 + ind = case @loc.firstVisitInfo of + NoneVis -> error "wrapper: initial state should have a next visit but it has none" + OneVis _ -> empty + ManyVis -> @loc.k_type >|< "_v" >|< initv + extra = if dummyTokenVisit @lhs.options + then pp $ dummyArg @lhs.options True + else empty + convert = case Map.lookup initv @lhs.allVisitKinds of + Just kind -> case kind of + VisitPure _ -> text "lift" + VisitMonadic -> empty + _ -> empty + unMonad | monadicWrappers @lhs.options = empty + | otherwise = unMon @lhs.options + in unMonad >#< "(" + >-< indent 2 + ("act >>= \\" >#< @loc.addbang (pp "sem") >#< "->" -- run the per-node monadic code to get the initial state (of the root) + >-< "lift" >#< pp_parens arg >#< ">>= \\" >#< @loc.addbangWrap (pp "arg") >#< "->" + >-< convert >#< pp_parens ("inv_" >|< @nt >|< "_s" >|< @initial >#< "sem" >#< ind >#< "arg" >#< extra) >#< ">>= \\" >#< pat >#< "->" -- invoke initial state (of the root) + >-< "lift" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist) + ) + >-< ")" ) + >-< if lateHigherOrderBinding @lhs.options + then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName) + else empty + loc.wrapper_dcl = (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params -- TODO : Remove ? >#< "->" + >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params)) + +------------------------------------------------------------------------------- +-- Collection of NT / Production sem funs references +------------------------------------------------------------------------------- + +ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ] +SEM ENonterminal | ENonterminal + lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs + lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps + loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname + loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp + loc.semFunBndNm = lateSemNtLabel @nt + +SEM EProduction | EProduction + lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef + lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp + loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname + loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp + loc.semFunBndNm = lateSemConLabel @lhs.nt @con + +-- Generate a dictionary that contains the semantics of all semantic functions +SEM ExecutionPlan | ExecutionPlan + loc.wrappersExtra = if lateHigherOrderBinding @lhs.options + then @loc.lateSemBndDef + else empty + loc.commonExtra = if lateHigherOrderBinding @lhs.options + then @loc.lateSemBndTp + else empty + loc.lateSemBndTp = "::" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName + >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps) + loc.lateSemBndDef = lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName + >-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName + >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs ) + +------------------------------------------------------------------------------- +-- Production semantic functions +------------------------------------------------------------------------------- +ATTR EProduction [ | | sem_prod : {PP_Doc} + sem_prod_tys : {PP_Doc} ] +ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} + sem_prod_tys USE {>-<} {empty} : {PP_Doc} ] + +ATTR EProduction EProductions [ initial : {StateIdentifier} + allstates : {Set StateIdentifier} | | ] +SEM ENonterminal + | ENonterminal prods.initial = @initial + prods.allstates = @loc.allstates + +ATTR EChild [ | | argtps : { PP_Doc } + argpats : { PP_Doc } + recfields USE {++} {[]} : { [Identifier] }] +ATTR EChildren [ | | argtps USE {:} {[]} : { [PP_Doc] } + argpats USE {:} {[]} : { [PP_Doc] } + recfields USE {++} {[]} : { [Identifier] }] + +SEM EChild + | EChild lhs.argtps = case @kind of + ChildSyntax -> pp_parens $ ppDefor @tp -- TODO Remove? >#< "->" + ChildReplace tp -> pp_parens $ ppDefor tp -- TODO Remove? >#< "->" + _ -> empty -- higher order attribute + loc.argpats = case @kind of + ChildSyntax -> @name >|< "_" -- no strictification of children semantics to allow infinite trees + ChildReplace _ -> @name >|< "_" + _ -> empty + + lhs.recfields = case @kind of + ChildSyntax -> [@name] -- no strictification of children semantics to allow infinite trees + ChildReplace _ -> [@name] + _ -> [] + + -- | ETerm lhs.argtps = (pp_parens $ show @tp) >#< "572->" -- TODO Remove? + | ETerm lhs.argtps = pp_parens $ show @tp + loc.argpats = @loc.addbang $ text $ fieldname @name -- terminals may be strict (perhaps this should become an option) + lhs.recfields = [@name] + +{ +ppDefor :: Type -> PP_Doc +ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args) +ppDefor (Haskell s) = text s +} + +SEM EProduction + | EProduction loc.t_type = "T_" >|< @lhs.nt + loc.t_params = ppSpaced @lhs.params + loc.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs + -- A bit ugly, but this code renames arguments and puts an underscore when the argument + -- is never used. This avoids compiler warnings of unused variables. + loc.args = map (\x -> let (name,arg) = case show x of + "" -> ("", empty) + '!':name -> ("arg_" ++ name, "!arg_" >|< name) + name -> ("arg_" ++ name, "arg_" >|< name) + in if null name || name `Set.member` @loc.usedArgs + then arg + else text "_") @children.argpats + loc.semname = "sem_" ++ show @lhs.nt ++ "_" ++ show @con + loc.sem_tp = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps + >#< (if length @children.argtps > 0 then "->" else "") + >#< @loc.t_type >#< @loc.t_params -- TODO Keep -> here? + loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints) + loc.quantPP2 = ppQuants (@lhs.params ++ @params) + + lhs.sem_prod_tys = @loc.semname >#< " ::" >#< @loc.sem_tp + + loc.sem_prod = @loc.semname >#< " ::" >#< @loc.sem_tp + >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.t_type) + @loc.mbInitializer @loc.outerlet ("lift" >#< "st" >|< @lhs.initial) + loc.mkSemBody = \prefix mbInit outerlet ret -> + case mbInit of + Nothing -> prefix >#< pp_parens ret >#< "where" + >-< indent 3 outerlet -- code for states and visits + Just m -> prefix >#< "(" >#< "do" -- TODO: desugar + >-< indent 1 ( + m + >-< "let" + >-< indent 2 outerlet -- code for the states and visits + >-< ret ) + >-< indent 1 ")" + + loc.mbInitializer = --some monadic actions, performed upon attaching a child, can + -- be specified here. The resulting bindings of these actions are + -- in scope of the rules of the production + if parallelInvoke @lhs.options + then (Nothing :: Maybe PP_Doc) -- perhaps do some per-node registation, etc. For now: nothing + else Nothing -- nothing special here + loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules + loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates + loc.genstfn = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits + prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits + stNm = "st" >|< st + lhs = bang stNm >#< "=" >#< + ( -- generating a lambda for the same reasons as generating + -- a lambda for rules: to ensure that overloading is + -- resolved for all visit functions and rules together. + if st == @lhs.initial + then empty + else "\\" >#< @loc.stargs st >#< "->" + ) + + cCon = "C_" >|< @lhs.nt >|< "_s" >|< st + bang | st == @lhs.initial = @loc.addbang -- initial state is not parameterized + | otherwise = id + + -- note about the initial state: the initial state should be the only + -- state-binding that is not a function. It is non-recursive and not needed + -- anywhere except delivered as initial result. This binding therefore does + -- not end up needlessly in any closure. + in case nextVisitInfo of + NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced + -- thus generating it is not needed (and omitting it may catch some small mistakes). + if st == @lhs.initial + then lhs >#< cCon -- empty state + else empty -- no state generated + OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId) + ManyVis -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st) + loc.stargs = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap + in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str + | otherwise = @loc.addbang (pp str) + in case mbAttr of + Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> + case Map.lookup nm @loc.localAttrTypes of + Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) + Nothing -> match + Just attr | not (noPerStateTypeSigs @lhs.options) -> + case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of + Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) + Nothing -> match + _ -> match + | (str,mbAttr) <- Map.assocs attrs + ] >#< dummyPat @lhs.options (Map.null attrs) + + loc.stks = \st -> if null (@loc.stvisits st) + then empty + else "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "t" >#< "->" >#< "t" + >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "=" + >#< "v" >|< v) $ @loc.stvisits st) + loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits + loc.stvs = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st] + visits.mrules = @rules.mrules + +{ +mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc +mklet prefix defs body = + prefix + >-< indent (length (show prefix)) + ("let" + >-< indent 4 defs + >-< "in" >#< body) +} + +------------------------------------------------------------------------------- +-- Visit semantic functions +------------------------------------------------------------------------------- +ATTR Visit [ | | sem_visit : { (StateIdentifier,Bool -> PP_Doc) } ] +ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ] + +SEM Visit + | Visit lhs.sem_visit = ( @from + , \_ -> + -- TODO: Generate type signature "v" >|< @ident >#< "::" >#< @loc.nameTIn_visit >#< "->" >#< @loc.nameT_visit >#< @loc.t_params >-< + + -- Haskell: generate a lambda here as well instead of a function definition + -- >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats)) + -- Clean: generate a function + "v" >|< @ident >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats)) >#< "=" + >#< ( if dummyTokenVisit @lhs.options + then pp $ dummyPat @lhs.options True -- extra (but unused) argument + else empty + ) + -- >#< "->" + -- >#< "(" + >-< indent 10 (@loc.stepsInitial + >-< indent 4 @steps.sem_steps) >-< indent 10 @loc.stepsClosing + -- >#< ")" + ) + loc.stepsInitial = case @kind of + VisitPure False -> text "let" + VisitPure True -> empty + VisitMonadic -> text "do" + loc.stepsClosing = let decls = @loc.nextStBuild + >-< @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval + in case @kind of + VisitPure False -> indent 4 decls + >-< "in" >#< resultValName + VisitPure True -> "let" >#< decls + >-< indent 1 ("in" >#< resultValName) + VisitMonadic -> "let" >#< decls + >-< "lift" >#< resultValName + loc.vname = "v" >|< @ident + loc.inhpats = ppSpaced $ map (\arg -> pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh + loc.inhargs = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh + loc.synargs = ppSpaced $ map (\arg -> attrname @lhs.options False _LHS arg) $ Set.toList @syn + loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap + loc.nextargs = ppSpaced $ Map.keys $ @loc.nextargsMp + loc.nextst = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp) + loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef + (loc.nextStBuild, loc.nextStRef) + = case @loc.nextVisitInfo of + NoneVis -> (empty, empty) + _ -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName) + +{ +resultValName :: String +resultValName = "ag__result_" + +nextStName :: String +nextStName = "ag__st_" +} + +-- Propagate the visit kind to the steps +ATTR VisitStep VisitSteps [ kind : VisitKind | | ] +SEM Visit | Visit steps.kind = @kind + +-- the steps in this group should be executed in a pure fashion +SEM VisitStep | PureGroup + steps.kind = VisitPure @ordered + +ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ] +ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ] +SEM VisitStep + | Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules + (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of + Left e -> (Seq.singleton e, empty) + Right stmt -> (Seq.empty, stmt) + | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros + (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses) + = case @loc.attachItf @lhs.kind @lhs.fmtMode of + Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) + Right (code, defs, uses) -> (Seq.empty, code, defs, uses) + | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit + (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of + Left e -> (Seq.singleton e, empty, empty) + Right (pat,expr) -> (Seq.empty, pat, expr) + + lhs.sem_steps = let decl = case @lhs.kind of + VisitPure _ -> @loc.patPP >#< "=" >#< @loc.exprPP + VisitMonadic -> @loc.exprPP >#< ">>= \\" >#< @loc.patPP >#< "->" + in fmtDecl False @lhs.fmtMode decl + loc.convToMonad = case @loc.callKind of + VisitPure _ -> text "lift" + VisitMonadic -> empty + loc.callKind = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds + | Sim lhs.sem_steps = @steps.sem_steps + | PureGroup lhs.sem_steps = case @lhs.fmtMode of + FormatDo -> "let" >#< @steps.sem_steps -- formatted as a let-block (not a line-let) + _ -> @steps.sem_steps + +-- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing +-- declarations, because that determines how we need to wrap declarations +-- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo +ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ] +SEM Visit | Visit + steps.fmtMode = case @kind of + VisitPure False -> FormatLetDecl + VisitPure True -> FormatLetLine + VisitMonadic -> FormatDo + +SEM VisitStep | PureGroup + steps.fmtMode = case @lhs.fmtMode of + FormatDo -> FormatLetDecl + mode -> mode + +{ +parResultName :: String +parResultName = "__outcome_" + +fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc +fmtDecl declPure fmt decl = case fmt of + FormatLetDecl -> pp decl + FormatLetLine -> "let" >#< decl >#< "in" + FormatDo | declPure -> "let" >#< decl >#< "in" + | otherwise -> pp decl +} + +-- +-- Some properties of VisitStep(s) +-- + +-- Used arguments +ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ] +SEM ERule + | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs + +SEM EChild + | EChild +usedArgs = \s -> case @kind of + ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s + _ -> s + + +-- Number of steps in a 'Sim' block +ATTR VisitSteps [ | | size : Int ] +SEM VisitSteps + | Nil lhs.size = 0 + | Cons lhs.size = 1 + @tl.size + +-- Number the steps in a 'Sim' block +ATTR VisitSteps VisitStep [ | index : Int | ] +SEM VisitSteps | Cons + hd.index = @lhs.index -- copy rule + tl.index = 1 + @lhs.index + lhs.index = @tl.index -- copy rule +SEM Visit | Visit steps.index = 0 +SEM VisitStep | Sim steps.index = 0 + lhs.index = @lhs.index -- needed for if we ever allow nested Sims + +-- Is this the last step? +ATTR VisitSteps VisitStep [ | | isLast : Bool ] +ATTR VisitStep [ isLast : Bool | | ] +SEM VisitSteps + | Nil lhs.isLast = True + | Cons lhs.isLast = False + hd.isLast = @tl.isLast + +SEM VisitStep | Sim + loc.isMonadic = case @lhs.kind of + VisitMonadic -> True + _ -> False + + +-- Child introduction +ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ] + +ATTR Visits Visit + VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ] + +SEM EProduction + | EProduction visits.childintros = @children.childintros + +SEM EChild + | ETerm lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty)) + | EChild lhs.childintros = Map.singleton @name @loc.introcode + loc.isDefor = case @tp of + NT _ _ defor -> defor + _ -> False + loc.valcode = case @kind of + ChildSyntax -> "arg_" >|< @name >|< "_" + ChildAttr -> -- decide if we need to invoke the sem-function under the hood + let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options -- when sepsemmods is not enabled, the indirection can be optimized away + then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr + else "sem_" >|< @loc.nt + | otherwise = empty -- no need to intro a terminal + in pp_parens (prefix >#< instname @name) + ChildReplace _ -> -- the higher-order attribute is actually a function that transforms + -- the semantics of the child (always deforested) + pp_parens (instname @name >#< @name >|< "_") + loc.aroundcode = if @hasAround + then locname @lhs.options @name >|< "_around" + else empty + loc.introcode = \kind fmtMode -> + let pat = text $ stname @name @loc.initSt + patStrict = @loc.addbang pat + attach = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode) + runAttach = unMon @lhs.options >#< pp_parens attach + decl = case kind of + VisitPure False -> pat >#< "=" >#< runAttach + VisitPure True -> patStrict >#< "=" >#< runAttach + VisitMonadic -> attach >#< ">>= \\" >#< patStrict >#< "->" + in if compatibleAttach kind @loc.nt @lhs.options + then Right ( fmtDecl False fmtMode decl + , Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro + , case @kind of -- variables used by the child introduction + ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr + ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options) + then id -- the sem dictionary attr is not used + else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) + ) $ + ( if @hasAround + then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing + else id + ) $ Map.empty + ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function + ChildSyntax -> Map.empty + ) + else Left $ IncompatibleAttachKind @name kind + loc.nt = extractNonterminal @tp + +{ +stname :: Identifier -> Int -> String +stname child st = "st_" ++ getName child ++ "X" ++ show st + +-- should actually return some conversion info +compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool +compatibleAttach _ _ _ = True + +unMon :: Options -> PP_Doc +unMon options + | parallelInvoke options = text "'System.IO.Unsafe'.unsafePerformIO" -- IO monad + | otherwise = text "'Control.Monad.Identity'.runIdentity" -- identity monad +} + +-- rules +ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc} + mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ] + +SEM ERule | ERule + lhs.sem_rules = if @loc.used == 0 + then empty + else @loc.rulecode + loc.rulecode = ( if @loc.genpragma + then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of + -- type errors in the rule. It will definitely not be precise, and may take some additional + -- source space, but let's see if it's worth it in practice. + else empty + ) + >-< @loc.lambda + >-< indent ((column @rhs.pos - 2) `max` 2) + ( if @loc.genpragma + then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma + else @rhs.semfunc + ) + loc.pragma = "/*# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#*/" + loc.endpragma = ppWithLineNr (\ln -> "/*# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#*/") + loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos + loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos)) + + -- This comment describes the Haskell rationale for lambdas + -- we generate a simple pattern binding because of overloading-resolving during the type inference process. + -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context). + -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have + -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead + -- of a function definition. + -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures + -- but are lambda-lifted instead. + -- loc.lambda = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->" + + -- For Clean, we do not want to generate lambdas, but functions instead + loc.lambda = @name >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "=" + + loc.argPats = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str + | otherwise = @loc.addbang1 (pp str) + in case mbAttr of + Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> + case Map.lookup nm @lhs.localAttrTypes of + Just tp -> pp_parens (pp_parens match) -- TODO Remove? >#< "::" >#< ppTp tp) + Nothing -> match + Just attr | not (noPerRuleTypeSigs @lhs.options) -> + case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of + Just tpDoc -> pp_parens (pp_parens match) -- TODO Remove? >#< "::" >#< tpDoc) + Nothing -> match + _ -> match + | (str,mbAttr) <- Map.assocs @rhs.attrs + ] + loc.argExprs = ppSpaced [ case mbAttr of + Nothing -> "arg_" >|< str + _ -> text str + | (str,mbAttr) <- Map.assocs @rhs.attrs + ] + loc.stepcode = \kind fmtMode -> if kind `compatibleRule` @pure + then Right $ let oper | @pure = "=" + | otherwise = "<-" -- TODO Desugar + decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs) + tp = if @pure && not (noPerRuleTypeSigs @lhs.options) + then @pattern.attrTypes + else empty + in fmtDecl @pure fmtMode (tp >-< decl) + else Left $ IncompatibleRuleKind @name kind + + lhs.mrules = Map.singleton @name @loc.stepcode + +ATTR Expression [ | | tks : {[HsToken]} ] +SEM Expression + | Expression lhs.tks = @tks + +{ +dummyPat :: Options -> Bool -> PP_Doc +dummyPat opts noArgs + | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples + | tupleAsDummyToken opts = if strictDummyToken opts + then text "Void" + else text "(_)" + | otherwise = let match | strictDummyToken opts = "!_" + | otherwise = "_" + in pp_parens (match >#< "::" >#< dummyType opts noArgs) + where match | strictDummyToken opts = "(!_)" + | otherwise = "_" + +dummyArg :: Options -> Bool -> PP_Doc +dummyArg opts noArgs + | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples + | tupleAsDummyToken opts = text "Void" + | otherwise = text "GHC.Prim.realWorld#" + +dummyType :: Options -> Bool -> PP_Doc +dummyType opts noArgs + | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples + | tupleAsDummyToken opts = text "Void" + | otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)" +} + +{ +-- rules are "deinlined" to prevent needless code duplication. +-- if there is only a bit of duplication, we allow ghc to decide if it is worth it. +-- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it. +ruleInlineThresholdSoft :: Int +ruleInlineThresholdSoft = 3 + +ruleInlineThresholdHard :: Int +ruleInlineThresholdHard = 5 + +reallyOftenUsedThreshold :: Int +reallyOftenUsedThreshold = 12 +} + +ATTR Expression [ | | pos : {Pos} ] +SEM Expression | Expression lhs.pos = @pos + +-- pattern and expression semantics +ATTR Pattern [ | | sem_lhs : { PP_Doc } ] +ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ] +ATTR Pattern Patterns [ | | ] + +SEM Pattern + | Alias loc.varPat = text $ attrname @lhs.options False @field @attr + loc.patExpr = if @pat.isUnderscore + then @loc.varPat + else @loc.varPat >|< "@" >|< @pat.sem_lhs + lhs.sem_lhs = @loc.addbang1 @loc.patExpr + | Product lhs.sem_lhs = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs + | Constr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs + | Underscore lhs.sem_lhs = text "_" + | Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs + +-- Check if a pattern is just an underscore +ATTR Pattern [ | | isUnderscore:{Bool}] +SEM Pattern + | Constr lhs.isUnderscore = False + | Product lhs.isUnderscore = False + | Alias lhs.isUnderscore = False + | Underscore lhs.isUnderscore = True + +-- Collect the attributes defined by a pattern +ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ] +SEM Pattern | Alias + lhs.attrs = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs + +-- All attribute types of this pattern +ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ] +SEM Pattern | Alias + loc.mbTp = if @field == _LHS + then Map.lookup @attr @lhs.synmap + else if @field == _LOC + then Map.lookup @attr @lhs.localAttrTypes + else Nothing + lhs.attrTypes = empty -- Don't generate these type signatures; increases performance in Clean + -- maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp + -- >-< @pat.attrTypes + +-- Collect the attributes used by the right-hand side +ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] +SEM HsToken + | AGLocal lhs.attrs = Map.singleton (fieldname @var) Nothing + | AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST' + then Nothing -- should not be used in the first place + else Just $ mkNonLocalAttr (@field == _LHS) @field @attr + lhs.attrs = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr + +{ +data NonLocalAttr + = AttrInh Identifier Identifier + | AttrSyn Identifier Identifier deriving Show + +mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr +mkNonLocalAttr True = AttrInh -- True: inherited attr +mkNonLocalAttr False = AttrSyn + +lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc +lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs +lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns + +-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that +-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. +-- However, for now we simply decide to return Nothing in this case, which skips the type annotation. +lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc +lookupType child name attrMp childMp + | noParameters childTp = Just ppDoc + | otherwise = Nothing + where + attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs + childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp + nonterm = extractNonterminal childTp + childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp + ppDoc = ppTp attrTp + +noParameters :: Type -> Bool +noParameters (Haskell _) = True +noParameters (NT _ args _) = null args +} + +ATTR Expression [ | | semfunc : {PP_Doc} ] + +SEM Expression + | Expression lhs.attrs = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks + lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks + loc.inhhstoken = Inh_HsToken @lhs.options + +-- child visit map +ATTR Visit + Visits + EProduction + EProductions + ENonterminal + ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} + | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ] + +ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ] + +SEM ExecutionPlan + | ExecutionPlan nonts.allchildvisit = @nonts.childvisit + +SEM Visit + | Visit + loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits + lhs.childvisit = Map.singleton @ident @loc.invokecode + loc.invokecode = \chn kind -> -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit + if kind `compatibleKind` @kind + then Right $ + let pat | isLazyKind @kind = pat0 + | otherwise = @loc.addbang pat0 + pat0 = pp_parens pat1 + pat1 = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname @lhs.options True chn) $ Set.toList @syn) + >#< cont + cont = case @loc.nextVisitInfo of + NoneVis -> empty + _ -> ch1 + ch0 = text $ stname chn @from + ch1 = text $ stname chn @to + expr = case (kind, @kind) of + (VisitPure _, VisitPure _) -> expr0 + (VisitPure _, VisitMonadic) -> unMon @lhs.options >#< expr0 + (VisitMonadic, VisitPure _) -> "lift" >#< expr0 + (VisitMonadic, VisitMonadic) -> expr0 + expr0 = case @loc.prevVisitInfo of + NoneVis -> error "error: invocation of a visit from a state that has no next visits" + OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args + ManyVis -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 + >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args + args = pp_parens args0 >#< args1 + args0 = @loc.nameTIn_visit >#< @loc.inhargs chn + args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True + | otherwise = empty + in (pat, expr) -- pretty print of the pattern and the expression part + else Left $ IncompatibleVisitKind chn @ident kind @kind + +{ +-- a `compatibleKind` b means: can kind b be invoked from a +compatibleKind :: VisitKind -> VisitKind -> Bool +compatibleKind _ _ = True + +compatibleRule :: VisitKind -> Bool -> Bool +compatibleRule (VisitPure _) False = False +compatibleRule _ _ = True +} + +------------------------------------------------------------------------------- +-- Properties of rules +------------------------------------------------------------------------------- + +-- Construct an environment that counts how often certain rules are used +ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ] +ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ] + +SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage +SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1 +SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo + +{ +unionWithSum = Map.unionWith (+) +} + +-- Collect in what visit-kinds a rule is used +ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ] +SEM VisitStep | Sem + lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind) + +ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ] +SEM EProduction | EProduction + rules.ruleKinds = @visits.ruleKinds + +SEM ERule | ERule + loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds + loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds + +ATTR Pattern Patterns [ anyLazyKind : Bool | | ] + + +------------------------------------------------------------------------------- +-- Intra attributes +------------------------------------------------------------------------------- +{ +uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) +uwSetUnion = Map.unionWith Set.union + +uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) +uwMapUnion = Map.unionWith Map.union +} +ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} + | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ] + +ATTR Visit Visits [ terminaldefs : {Set String} | | ] +ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ] + +SEM EChild | ETerm + lhs.terminaldefs = Set.singleton $ fieldname @name + +SEM EProduction | EProduction + visits.allintramap = @visits.intramap + visits.terminaldefs = @children.terminaldefs + +SEM Visit + | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap + lhs.intramap = Map.singleton @from @loc.thisintra + loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap + loc.uses = let mp1 = @steps.uses + mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ] + in mp1 `Map.union` mp2 + loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh + loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs + loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ] + +ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)} + ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ] +ATTR Visit Visits + VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)} + ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ] + +SEM ERule + | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs + lhs.ruleuses = Map.singleton @name @rhs.attrs + +SEM EProduction + | EProduction visits.ruledefs = @rules.ruledefs + visits.ruleuses = @rules.ruleuses + +ATTR Visit Visits + EProduction + EProductions + ENonterminal + ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} + visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ] + +SEM Visit + | Visit lhs.visitdefs = Map.singleton @ident @syn + lhs.visituses = Map.singleton @ident @inh + +ATTR Visit Visits + VisitSteps VisitStep + EProduction EProductions + ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)} + avisituses : {Map VisitIdentifier (Set Identifier)} | | ] + +SEM ExecutionPlan + | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs + nonts.avisituses = @nonts.visituses + +ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String} + uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] +SEM VisitStep + | Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs + lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses + | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs + lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ] + in Map.insert (stname @child @from) Nothing $ convert $ + maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses + +------------------------------------------------------------------------------- +-- Identification of lazy intra defs within a production +-- +-- These identifiers will not be marked as strict in rules and state closures +------------------------------------------------------------------------------- + +ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ] +ATTR ERules ERule [ lazyIntras : {Set String} | | ] + +SEM Visit | Visit + loc.lazyIntrasInh = case @kind of + VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs + _ -> Set.empty + lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras + +SEM VisitStep | PureGroup + lhs.lazyIntras = if @ordered + then @steps.lazyIntras + else @steps.defs + +SEM EProduction | EProduction + loc.lazyIntras = @visits.lazyIntras + +------------------------------------------------------------------------------- +-- Pretty printing of haskell code +------------------------------------------------------------------------------- + +SEM HsTokens [ || tks : {[(Pos,String)]} ] + | Cons lhs.tks = @hd.tok : @tl.tks + | Nil lhs.tks = [] + +SEM HsToken + | AGLocal loc.tok = (@pos,fieldname @var) + +SEM HsToken [ || tok:{(Pos,String)}] + | AGField + loc.addTrace = case @rdesc of + Just d -> \x -> "(trace_n " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))" + Nothing -> id + lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr) + + | HsToken lhs.tok = (@pos, @value) + + | CharToken lhs.tok = (@pos, if null @value + then "" + else showCharShort (head @value) + ) + + | StrToken lhs.tok = (@pos, showStrShort @value) + | Err lhs.tok = (@pos, "") + +------------------------------------------------------------------------------- +-- Alternative code generation (sepsemmods) +------------------------------------------------------------------------------- + +ATTR ExecutionPlan [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc} + | | genIO : {IO ()} ] + +SEM ExecutionPlan + | ExecutionPlan lhs.genIO = do @loc.genMainModule + @loc.genCommonModule + @nonts.genProdIO + loc.mainModuleFile = @lhs.mainFile + loc.ppMonadImports = pp "import qualified Control.Monad.Identity" + loc.genMainModule = writeModule @loc.mainModuleFile + ( [ pp $ @lhs.iclModuleHeader @lhs.mainName "" "" False + , @loc.ppMonadImports + , pp $ "import " ++ @lhs.mainName ++ "_common" + ] + ++ @nonts.imports + ++ [@lhs.mainBlocksDoc] + ++ [@loc.wrappersExtra] + ++ @nonts.appendMain + ) + loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") + loc.genCommonModule = writeModule @loc.commonFile + ( [ pp $ @lhs.iclModuleHeader @lhs.mainName "_common" "" True + , @loc.ppMonadImports + , @lhs.importBlocks + , @lhs.textBlocks + , @loc.commonExtra + ] + ++ @nonts.appendCommon + ) + +ATTR ENonterminal [ | | appendCommon, appendMain : { PP_Doc } ] +ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ] + +SEM ENonterminal + | ENonterminal lhs.appendMain = (if @nt `Set.member` @lhs.wrappers + then @loc.wr_inh_icl + >-< @loc.wr_syn_icl + >-< @loc.wrapper_icl + else empty) + >-< @loc.sem_nt + lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty) + >-< @loc.t_init_icl + >-< @loc.t_states_icl + >-< @loc.k_states + >-< @prods.t_visits + +ATTR EProduction EProductions + ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]} + genProdIO USE {>>} {return ()} : {IO ()} ] + +SEM EProduction + | EProduction lhs.imports = [pp $ "import " ++ @loc.moduleName] + loc.moduleName = @lhs.mainName ++ @loc.suffix + loc.suffix = '_' : show @lhs.nt ++ ('_' : show @con) + loc.outputfile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix) + loc.ppMonadImports = pp "import qualified Control.Monad.Identity" + lhs.genProdIO = writeModule @loc.outputfile + [ pp $ @lhs.iclModuleHeader @lhs.mainName @loc.suffix @loc.semname True + , @lhs.importBlocks + , @loc.ppMonadImports + , pp $ "import " ++ @lhs.mainName ++ "_common" + , @loc.sem_prod + ] + +{ +renderDocs :: [PP_Doc] -> String +renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" + +writeModule :: FilePath -> [PP_Doc] -> IO () +writeModule path docs + = do bExists <- doesFileExist path + if bExists + then do input <- readFile path + seq (length input) (return ()) + if input /= output + then dumpIt + else return () + else dumpIt + where + output = renderDocs docs + dumpIt = writeFile path output + +cleanIclModuleHeader :: Options -> String -> String +cleanIclModuleHeader flags input + = case moduleName flags + of Name nm -> genMod nm + Default -> genMod (defaultModuleName input) + NoName -> "" + where genMod x = "implementation module " ++ x + +cleanDclModuleHeader :: Options -> String -> Maybe String -> String +cleanDclModuleHeader flags input export + = case moduleName flags + of Name nm -> genMod nm + Default -> genMod (defaultModuleName input) + NoName -> "" + where genMod x = "definition module " ++ x ++ genExp export x + genExp Nothing _ = "" + genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")" + +defaultModuleName :: String -> String +defaultModuleName = dropExtension + +mkIclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String +mkIclModuleHeader Nothing defaultName suffix _ _ + = "implementation module " ++ defaultName ++ suffix +mkIclModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports + = "implementation module " ++ name ++ suffix ++ "\n" ++ imports ++ "\n" + +mkDclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String +mkDclModuleHeader Nothing defaultName suffix _ _ + = "definition module " ++ defaultName ++ suffix +mkDclModuleHeader (Just (name, exports, _)) _ suffix addExports replaceExports + = "definition module " ++ name ++ suffix ++ ex ++ "\n" + where + ex = if null exports || (replaceExports && null addExports) + then "" + else if null addExports + then exports + else if replaceExports + then addExports + else exports ++ "," ++ addExports +} + + +-- +-- Bang pattern usage +-- + +SEM ERule | ERule loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM Visit | Visit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM ENonterminal | ENonterminal loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM EProduction | EProduction loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM EChild | EChild loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM EChild | ETerm loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM VisitStep | ChildVisit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM Pattern | Alias Constr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x + +SEM Visit | Visit loc.addbang1 = if isLazyKind @kind then id else @loc.addbang +SEM ENonterminal | ENonterminal loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id +SEM ERule | ERule loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang +SEM Pattern | Alias Constr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang + +-- +-- Distribute single-visit-next map downward +-- + +ATTR EProductions EProduction Visits Visit + [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ] + +SEM ENonterminal | ENonterminal + prods.nextVisits = @nextVisits + prods.prevVisits = @prevVisits + +-- +-- Collect and distribute the from/to states of a visit +-- + +ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit + [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ] + +ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep + [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ] + +SEM Visit | Visit + lhs.fromToStates = Map.singleton @ident (@from, @to) + +SEM ExecutionPlan | ExecutionPlan + nonts.allFromToStates = @nonts.fromToStates + +SEM VisitStep | ChildVisit + (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates + + +-- +-- Collect and distribute the actual types of children of productions +-- + +ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ] +ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ] + +SEM EProduction | EProduction + loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes + +SEM EChild | EChild ETerm + lhs.childTypes = Map.singleton @name @tp + +-- +-- Distribute types of local attributes +-- + +ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ] +ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ] +ATTR ERules ERule Pattern Patterns [ localAttrTypes : {Map Identifier Type} | | ] + +SEM ENonterminal | ENonterminal + prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes + +SEM EProduction | EProduction + loc.localAttrTypes = Map.findWithDefault Map.empty @con @lhs.localAttrTypes + +-- +-- Collect and distribute visit kinds +-- + +ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep + [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ] + +SEM Visit | Visit + lhs.visitKinds = Map.singleton @ident @kind + +SEM ExecutionPlan | ExecutionPlan + nonts.allVisitKinds = @nonts.visitKinds + +-- +-- Collect and distribute the initial state of nonterminals +-- + +ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ] +ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep + [ allInitStates : {Map NontermIdent Int} | | ] + +SEM ENonterminal | ENonterminal + lhs.initStates = Map.singleton @nt @initial + +SEM ExecutionPlan | ExecutionPlan + nonts.allInitStates = @nonts.initStates + +SEM EChild | EChild + loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates + +-- +-- Push the nonterminal type downward +-- + +ATTR EProductions EProduction [ ntType : Type | | ] +SEM ENonterminal | ENonterminal + loc.ntType = NT @nt (map show @params) False + +-- +-- Collect errors contained in rules that should be yielded when the +-- rules are scheduled. +-- + +ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] +SEM ERule | ERule + lhs.errors = case @mbError of + Just e | @loc.used > 0 -> Seq.singleton e + _ -> Seq.empty + diff --git a/src-ag/ExecutionPlan2Hs.ag b/src-ag/ExecutionPlan2Hs.ag --- a/src-ag/ExecutionPlan2Hs.ag +++ b/src-ag/ExecutionPlan2Hs.ag @@ -1,1711 +1,1711 @@ -INCLUDE "ExecutionPlan.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "HsToken.ag" - -imports -{ -import ExecutionPlan -import Pretty -import PPUtil -import Options -import Data.Monoid(mappend,mempty) -import Data.Maybe -import Debug.Trace -import System.IO -import System.Directory -import System.FilePath -import UU.Scanner.Position - -import TokenDef -import HsToken -import ErrorMessages - -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Sequence(Seq) -import qualified Data.Sequence as Seq -import Data.Foldable(toList) -} - -ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild - [ importBlocks : PP_Doc - pragmaBlocks : String - textBlocks : PP_Doc - moduleHeader : {String -> String -> String -> Bool -> String} - mainFile : String - mainName : String | | ] - -------------------------------------------------------------------------------- --- Options -------------------------------------------------------------------------------- -ATTR ExecutionPlan - ENonterminals ENonterminal - EProductions EProduction - ERules ERule - EChildren EChild - Expression - HsToken HsTokens HsTokensRoot - Pattern Patterns - Visits Visit - VisitSteps VisitStep [ options : {Options} | | ] -ATTR EProductions EProduction [ rename : {Bool} | | ] - -SEM ENonterminal - | ENonterminal prods.rename = rename @lhs.options - -------------------------------------------------------------------------------- --- Context info (nonterminal ident, constructor ident, nonterm params, etc.) -------------------------------------------------------------------------------- - -ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ] -SEM ENonterminal - | ENonterminal prods.nt = @nt - -ATTR EChildren EChild ERules ERule Visits Visit - [ con : ConstructorIdent | | ] - -SEM EProduction - | EProduction children.con = @con - rules.con = @con - visits.con = @con - -ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ] -SEM ENonterminal | ENonterminal - prods.params = @params - -ATTR EProductions EProduction [ classCtxs : ClassContext | | ] -SEM ENonterminal | ENonterminal - prods.classCtxs = @classCtxs - -------------------------------------------------------------------------------- --- Default output -------------------------------------------------------------------------------- -ATTR ExecutionPlan [ | | output : {PP_Doc} ] - -SEM ExecutionPlan - | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra - -ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent} - | | output USE {>-<} {empty} : {PP_Doc} ] - -SEM ExecutionPlan - | ExecutionPlan nonts.wrappers = @wrappers - -SEM ENonterminal - | ENonterminal lhs.output = ("-- " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-') - >-< (if dataTypes @lhs.options - then "-- data" - >-< @loc.datatype - >-< "" - else empty) - >-< (if @loc.hasWrapper - then "-- wrapper" - >-< @loc.wr_inh - >-< @loc.wr_syn - >-< @loc.wrapper - >-< "" - else empty) - >-< (if folds @lhs.options - then "-- cata" - >-< @loc.sem_nt - >-< "" - else empty) - >-< (if semfuns @lhs.options - then "-- semantic domain" - >-< @loc.t_init - >-< @loc.t_states - >-< @loc.k_states - >-< @prods.t_visits - >-< @prods.sem_prod - >-< "" - else empty) - loc.hasWrapper = @nt `Set.member` @lhs.wrappers - -------------------------------------------------------------------------------- --- Nonterminal datatype -------------------------------------------------------------------------------- -ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} - derivings : {Derivings} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.typeSyns = @typeSyns - nonts.derivings = @derivings - -SEM ENonterminal - | ENonterminal loc.classPP = ppClasses $ classCtxsToDocs @classCtxs - loc.aliasPre = "type" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "=" - loc.datatype = case lookup @nt @lhs.typeSyns of - Nothing -> "data" >#< @loc.classPP >#< @nt >#< @loc.t_params - >-< ( if null @prods.datatype - then empty - else indent 2 $ vlist $ ( ("=" >#< head @prods.datatype) - : (map ("|" >#<) $ tail @prods.datatype)) - ) - >-< indent 2 @loc.derivings - Just (List t) -> @loc.aliasPre >#< "[" >#< show t >#< "]" - Just (Maybe t) -> @loc.aliasPre >#< "Maybe" >#< pp_parens (show t) - Just (Tuple ts) -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts) - Just (Either l r) -> @loc.aliasPre >#< "Either" >#< pp_parens (show l) >#< pp_parens (show r) - Just (Map k v) -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v) - Just (IntMap t) -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t) - Just (OrdSet t) -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (show t) - Just IntSet -> @loc.aliasPre >#< "Data.IntSet.IntSet" --- Just x -> error $ "Type " ++ show x ++ " is not supported" - loc.derivings = case Map.lookup @nt @lhs.derivings of - Nothing -> empty - Just s -> if Set.null s - then empty - else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s) - -{ -classCtxsToDocs :: ClassContext -> [PP_Doc] -classCtxsToDocs = map toDoc where - toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args)) - -classConstrsToDocs :: [Type] -> [PP_Doc] -classConstrsToDocs = map ppTp - -ppClasses :: [PP_Doc] -> PP_Doc -ppClasses [] = empty -ppClasses xs = pp_block "(" ")" "," xs >#< "=>" - -ppQuants :: [Identifier] -> PP_Doc -ppQuants [] = empty -ppQuants ps = "forall" >#< ppSpaced ps >#< "." -} - -ATTR EProduction [ | | datatype : {PP_Doc} ] -ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} ] - --- we generate the data type in the type-class style instead of the GADT style --- the GADT extension may be required if equality constraints are used -SEM EProduction - | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1 - >#< conname @lhs.rename @lhs.nt @con - >#< ppConFields (dataRecords @lhs.options) @children.datatype - loc.classPP1 = ppClasses (classConstrsToDocs @constraints) - loc.quantPP1 = ppQuants @params - -{ --- first parameter indicates: generate a record or not -ppConFields :: Bool -> [PP_Doc] -> PP_Doc -ppConFields True flds = ppListSep "{" "}" ", " $ filter (not . isEmpty) flds -ppConFields False flds = ppSpaced flds -} - - -ATTR EChild [ | | datatype : {PP_Doc} ] -ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]} ] - --- Note: the child may be a higher-order attribute, and its semantics may be deforested -SEM EChild - | EChild ETerm - loc.tpDoc = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp - loc.strNm = recordFieldname @lhs.nt @lhs.con @name - loc.field = if dataRecords @lhs.options - then @loc.strNm >#< "::" >#< @loc.tpDoc - else @loc.tpDoc - loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x - | EChild lhs.datatype = case @kind of - ChildAttr -> empty -- higher order attributes are not part of the data type - _ -> @loc.field - - | ETerm lhs.datatype = @loc.field - -{ -ppTp :: Type -> PP_Doc -ppTp = text . typeToHaskellString Nothing [] -} - -------------------------------------------------------------------------------- --- Nonterminal semantic function -------------------------------------------------------------------------------- -SEM ENonterminal - | ENonterminal loc.fsemname = \x -> "sem_" ++ show x - loc.semname = @loc.fsemname @nt - loc.frecarg = \t x -> case t of - NT nt _ _ -> pp_parens (@fsemname nt >#< x) - _ -> pp x - - -- The sem_NT function is lazy in the AST: it depends on the application of "child" - -- rules to which extend the AST needs to be constructed. - loc.sem_tp = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params - loc.quantPP = ppQuants @params - loc.sem_nt = @loc.semPragma - >-< @loc.semname >#< "::" >#< @loc.sem_tp - >-< case lookup @nt @lhs.typeSyns of - Nothing -> @prods.sem_nt - Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Cons" - >#< @loc.semname >|< "_Nil" - >#< case t of - NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt >#< "list") - _ -> pp "list" - Just (Maybe t) -> @loc.semname >#< "Prelude.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing" - >-< @loc.semname >#< pp_parens ("Prelude.Just just") >#< "=" - >#< @loc.semname >|< "_Just" >#< @frecarg t "just" - Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "=" - >#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts) - Just (Either l r) -> @loc.semname >#< "(Prelude.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left" - >-< @loc.semname >#< "(Prelude.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right" - Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "Data.Map.foldrWithKey" - >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" - >#< case v of - NT nt _ _ -> pp_parens ("Data.Map.map" >#< @fsemname nt >#< "m") - _ -> pp "m" - Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "Data.IntMap.foldWithKey" - >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" - >#< case v of - NT nt _ _ -> pp_parens ("Data.IntMap.map" >#< @fsemname nt >#< "m") - _ -> pp "m" - Just (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry" - >#< @loc.semname >|< "_Nil" - >#< pp_parens ( - ( case t of - NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt) - _ -> empty - ) >#< pp_parens ("Data.IntSet.elems" >#< "s") - ) - Just IntSet -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry" - >#< @loc.semname >|< "_Nil" - >#< pp_parens ("Data.IntSet.elems" >#< "s") --- Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns - - -- precise inlining strategies for inlining - loc.inlineNt = not (lateHigherOrderBinding @lhs.options) && not @recursive && (@prods.count == 1 || (aggressiveInlinePragmas @lhs.options && not @loc.hasWrapper)) -- lucrative for inlining - loc.semPragma = if noInlinePragmas @lhs.options - then empty - else if @loc.inlineNt - then ppInline @loc.semname - else if helpInlining @lhs.options && not (lateHigherOrderBinding @lhs.options) - then ppInlinable @loc.semname - else ppNoInline @loc.semname - --- The number of productions -ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ] -SEM EProduction | EProduction lhs.count = {1} - --- The per-production cases for the sem_NT function -ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ] -SEM EProduction - | EProduction lhs.sem_nt = "sem_" >|< @lhs.nt >#< "(" >#< conname @lhs.rename @lhs.nt @con >#< ppSpaced @children.argpats >#< ")" - >#< "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw - -ATTR EChild [ | | argnamesw : { PP_Doc } ] -ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ] - -SEM EChild - | EChild lhs.argnamesw = case @kind of - ChildSyntax -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")" - ChildAttr -> empty -- no sem-case for a higher-order child - ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")" - | ETerm lhs.argnamesw = text $ fieldname @name - -------------------------------------------------------------------------------- --- Types of attributes -------------------------------------------------------------------------------- -ATTR ExecutionPlan - ENonterminals - ENonterminal [ inhmap : {Map NontermIdent Attributes} - synmap : {Map NontermIdent Attributes} | | ] - -ATTR EProductions EProduction - ERules ERule - Patterns Pattern - Visits - Visit [ inhmap : {Attributes} - synmap : {Attributes} - allInhmap : {Map NontermIdent Attributes} - allSynmap : {Map NontermIdent Attributes} | | ] - -SEM ENonterminal - | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap - (Just prods.synmap) = Map.lookup @nt @lhs.synmap - prods.allInhmap = @lhs.inhmap - prods.allSynmap = @lhs.synmap - -------------------------------------------------------------------------------- --- State datatypes -------------------------------------------------------------------------------- -{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)} - -ATTR Visit [ | | allvisits : { VisitStateState }] -ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}] -ATTR EProduction - EProductions [ | | allvisits: {[VisitStateState]}] - -SEM Visit - | Visit lhs.allvisits = (@ident, @from, @to) - -SEM EProductions - | Cons lhs.allvisits = @hd.allvisits -- just pick the first production - | Nil lhs.allvisits = error "Every nonterminal should have at least 1 production" - --- type of tree in a given state s -SEM ENonterminal - | ENonterminal loc.outedges = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits - loc.inedges = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits - loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges - loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits - loc.t_type = "T_" >|< @nt - loc.t_params = ppSpaced @params - loc.t_init = "newtype" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type >#< - pp_braces ( - "attach_">|< @loc.t_type >#< "::" - >#< ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params)) - loc.t_states = vlist $ map (\st -> - let nt_st = @nt >|< "_s" >|< st - t_st = "T_" >|< nt_st - k_st = "K_" >|< nt_st - c_st = "C_" >|< nt_st - inv_st = "inv_" >|< nt_st - nextVisit = Map.findWithDefault ManyVis st @nextVisits - in case nextVisit of - NoneVis -> "data" >#< t_st >#< @loc.t_params >#< "=" >#< c_st -- empty semantics - OneVis vId -> "newtype" >#< t_st >#< @loc.t_params >#< "=" >#< c_st - >#< (pp_braces $ inv_st >#< "::" >#< pp_parens (conNmTVisit @nt vId >#< @loc.t_params)) - ManyVis -> "data" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::" - >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("forall t." >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t")) - >#< "->" >#< t_st >#< @loc.t_params -- this is a conventional data type, but declared with GADT syntax - ) $ Set.toList @loc.allstates - --- type of a key which identifies a visit v from state s -SEM ENonterminal - | ENonterminal loc.k_type = "K_" ++ show @nt - loc.k_states = vlist $ map (\st -> - let nt_st = @nt >|< "_s" >|< st - k_st = "K_" >|< nt_st - outg = filter (\(v,f,t) -> f == st) @prods.allvisits - visitlist = vlist $ map (\(v,f,t) -> - @loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params) - ) outg - nextVisit = Map.findWithDefault ManyVis st @nextVisits - decl = "data" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist - in case nextVisit of - NoneVis -> empty - OneVis _ -> empty - ManyVis -> decl - ) $ Set.toList @loc.allstates - --- type of a visit v, with continuation as new state s -ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ] - -SEM EProductions - | Cons lhs.t_visits = @hd.t_visits -- just pick the first production - -SEM Visit - | Visit loc.nameT_visit = conNmTVisit @lhs.nt @ident - loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident - loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident - loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to - - loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state? - loc.typecon = case @kind of - VisitPure _ -> empty - VisitMonadic -> ppMonadType @lhs.options - - loc.t_params = ppSpaced @lhs.params - lhs.t_visits = "type" >#< @loc.nameT_visit >#< @loc.t_params >#< "=" >#< - pp_parens (@loc.nameTIn_visit >#< @loc.t_params) - >#< ( if dummyTokenVisit @lhs.options - then "->" >#< dummyType @lhs.options True -- Additional (unused though) argument - else empty - ) - >#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params) - >-< "data" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#< - @loc.inhpart - >-< "data" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#< - @loc.synpart >#< case @loc.nextVisitInfo of - NoneVis -> empty -- don't return a continuation at all - _ -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params) -- normal route: select the next semantics - loc.inhpart = @loc.ppTypeList @inh @lhs.inhmap - loc.synpart = @loc.ppTypeList @syn @lhs.synmap - loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of - Just tp -> ppTp tp ) $ Set.toList s - -{ -conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId -conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId -conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId -conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId - -ppMonadType :: Options -> PP_Doc -ppMonadType opts - | parallelInvoke opts = text "IO" - | otherwise = text "Identity" -} - -------------------------------------------------------------------------------- --- Inh and Syn wrappers -------------------------------------------------------------------------------- -SEM ENonterminal - | ENonterminal loc.wr_inh = @loc.genwrap "Inh" @loc.wr_inhs - loc.wr_syn = @loc.genwrap "Syn" @loc.wr_syns - loc.genwrap = \nm attr -> "data" >#< nm >|< "_" >|< @nt >#< @loc.t_params >#< "=" >#< nm >|< "_" >|< @nt >#< "{" - >#< (ppCommas $ map (\(i,t) -> i >|< "_" >|< nm >|< "_" >|< @nt >#< "::" - >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)) attr) >#< "}" - loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap - loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.synAttrs - loc.wr_inhs1 = Map.toList @loc.synAttrs - loc.wr_filter = if lateHigherOrderBinding @lhs.options - then Map.delete idLateBindingAttr - else id - loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap - loc.inhlist = map (lhsname @lhs.options True . fst) @loc.wr_inhs - loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1 - loc.synlist = map (lhsname @lhs.options False . fst) @loc.wr_syns - loc.wrapname = "wrap_" ++ show @nt - loc.inhname = "Inh_" ++ show @nt - loc.synname = "Syn_" ++ show @nt - loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits - loc.wrapper = @loc.wrapPragma - >-< (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params >#< "->" - >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params)) - >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act")) - >#< (@loc.addbang $ pp_parens (@loc.inhname - >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "=")) - >-< - indent 3 (case @initialv of - -- case where there are no inherited or synthesized attributes - [] -> @loc.synname >#< " { }" - initvs@(initv:_) -> - let extra = if dummyTokenVisit @lhs.options - then pp $ dummyArg @lhs.options True - else empty - unMonad | monadicWrappers @lhs.options = empty - | otherwise = unMon @lhs.options - genSteps _ [] = [] - genSteps curst (curv:nextvs) = setarg : dovis : genSteps nextst nextvs where - inCon = conNmTVisitIn @nt curv - outCon = conNmTVisitOut @nt curv - pat = @loc.addbang $ pp_parens $ pat0 - pat0 = outCon >#< ppSpaced (map (lhsname @lhs.options False) syns) >#< cont - cont | null nextvs = empty - | otherwise = pp "sem" - inhs = Set.toList $ Map.findWithDefault Set.empty curv @prods.visituses - syns = Set.toList $ Map.findWithDefault Set.empty curv @prods.visitdefs - arg = inCon >#< ppSpaced (map (lhsname @lhs.options True) inhs) - setarg = "let" >#< @loc.addbangWrap (pp "arg" >|< curv) >#< "=" >#< arg - ind = case Map.findWithDefault ManyVis curst @nextVisits of - NoneVis -> error "wrapper: initial state should have a next visit but it has none" - OneVis _ -> empty - ManyVis -> @loc.k_type >|< "_v" >|< initv - nextst = curst + 1 -- This is not correct, but works both for KW and AOAG - -- Should be lookup up based on visit - convert = case Map.lookup curv @lhs.allVisitKinds of - Just kind -> case kind of - VisitPure _ -> text "return" - VisitMonadic -> empty - dovis = pat >#< "<-" >#< convert >#< pp_parens - ("inv_" >|< @nt >|< "_s" >|< curst >#< "sem" >#< ind - >#< "arg" >|< curv >#< extra) - in unMonad >#< "(" - >-< indent 2 ( - "do" >#< ( @loc.addbang (pp "sem") >#< "<-" >#< "act" -- run the per-node monadic code to get the initial state (of the root) - >-< vlist (genSteps @initial initvs) - >-< "return" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist) - ) - ) - >-< ")" ) - >-< if lateHigherOrderBinding @lhs.options - then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName) - else empty - loc.wrapPragma = if parallelInvoke @lhs.options && not (monadicWrappers @lhs.options) - then ppNoInline @loc.wrapname -- required for the use of unsafePerformIO in case of the IO monad - else if noInlinePragmas @lhs.options - then empty - else ppInlinable @loc.wrapname -- ensure that the wrapper is exposed as inlinable - -------------------------------------------------------------------------------- --- Collection of NT / Production sem funs references -------------------------------------------------------------------------------- - -ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ] -SEM ENonterminal | ENonterminal - lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs - lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps - loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname - loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp - loc.semFunBndNm = lateSemNtLabel @nt - -SEM EProduction | EProduction - lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef - lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp - loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname - loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp - loc.semFunBndNm = lateSemConLabel @lhs.nt @con - --- Generate a dictionary that contains the semantics of all semantic functions -SEM ExecutionPlan | ExecutionPlan - loc.wrappersExtra = if lateHigherOrderBinding @lhs.options - then @loc.lateSemBndDef - else empty - loc.commonExtra = if lateHigherOrderBinding @lhs.options - then @loc.lateSemBndTp - else empty - loc.lateSemBndTp = "data" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName - >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps) - loc.lateSemBndDef = ( if noInlinePragmas @lhs.options - then empty - else if helpInlining @lhs.options && Set.size @wrappers == 1 - then ppInline $ lateBindingFieldNm @lhs.mainName -- inline in the single wrapper - else ppNoInline $ lateBindingFieldNm @lhs.mainName - ) - >-< lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName - >-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName - >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs ) - -------------------------------------------------------------------------------- --- Production semantic functions -------------------------------------------------------------------------------- -ATTR EProduction [ | | sem_prod : {PP_Doc} ] -ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ] - -ATTR EProduction EProductions [ initial : {StateIdentifier} - allstates : {Set StateIdentifier} | | ] -SEM ENonterminal - | ENonterminal prods.initial = @initial - prods.allstates = @loc.allstates - -ATTR EChild [ | | argtps : { PP_Doc } - argpats : { PP_Doc } ] -ATTR EChildren [ | | argtps USE {:} {[]} : { [PP_Doc] } - argpats USE {:} {[]} : { [PP_Doc] } ] - -SEM EChild - | EChild lhs.argtps = case @kind of - ChildSyntax -> ppDefor @tp >#< "->" - ChildReplace tp -> ppDefor tp >#< "->" - _ -> empty -- higher order attribute - loc.argpats = case @kind of - ChildSyntax -> @name >|< "_" -- no strictification of children semantics to allow infinite trees - ChildReplace _ -> @name >|< "_" - _ -> empty - | ETerm lhs.argtps = (pp_parens $ show @tp) >#< "->" - loc.argpats = @loc.addbang $ text $ fieldname @name -- terminals may be strict (perhaps this should become an option) - -{ -ppDefor :: Type -> PP_Doc -ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args) -ppDefor (Haskell s) = text s -} - -SEM EProduction - | EProduction loc.t_type = "T_" >|< @lhs.nt - loc.t_params = ppSpaced @lhs.params - loc.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs - -- A bit ugly, but this code renames arguments and puts an underscore when the argument - -- is never used. This avoids compiler warnings of unused variables. - loc.args = map (\x -> let (name,arg) = case show x of - "" -> ("", empty) - '!':name -> ("arg_" ++ name, "!arg_" >|< name) - name -> ("arg_" ++ name, "arg_" >|< name) - in if null name || name `Set.member` @loc.usedArgs - then arg - else text "_") @children.argpats - loc.semname = "sem_" ++ show @lhs.nt ++ "_" ++ show @con - loc.sem_tp = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps >#< @loc.t_type >#< @loc.t_params - loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints) - loc.quantPP2 = ppQuants (@lhs.params ++ @params) - loc.sem_prod = @loc.semInlinePragma - >-< @loc.semname >#< "::" >#< @loc.sem_tp - >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.scc >#< @loc.t_type) - @loc.mbInitializer @loc.outerlet ("return" >#< "st" >|< @lhs.initial) - loc.mkSemBody = \prefix mbInit outerlet ret -> - case mbInit of - Nothing -> prefix >#< pp_parens ret >#< "where" - >-< indent 3 outerlet -- code for states and visits - Just m -> prefix >#< "(" >#< "do" - >-< indent 1 ( - m - >-< "let" - >-< indent 2 outerlet -- code for the states and visits - >-< ret ) - >-< indent 1 ")" - - loc.mbInitializer = --some monadic actions, performed upon attaching a child, can - -- be specified here. The resulting bindings of these actions are - -- in scope of the rules of the production - if parallelInvoke @lhs.options - then (Nothing :: Maybe PP_Doc) -- perhaps do some per-node registation, etc. For now: nothing - else Nothing -- nothing special here - loc.scc = if genCostCentres @lhs.options - then ppCostCentre @loc.semname - else empty - loc.semInlinePragma = if noInlinePragmas @lhs.options - then empty - else ppNoInline @loc.semname -- prevent the semantic functions of constructors to be inlined (e.g. in the nt sem-funs) - loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules - loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates - loc.genstfn = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits - prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits - stNm = "st" >|< st - lhs = pragma >-< bang stNm >#< "=" >#< - ( -- generating a lambda for the same reasons as generating - -- a lambda for rules: to ensure that overloading is - -- resolved for all visit functions and rules together. - if st == @lhs.initial - then empty - else "\\" >#< @loc.stargs st >#< "->" - ) - - pragma = if noInlinePragmas @lhs.options - then empty - else if helpInlining @lhs.options - then case prevVisitInfo of - ManyVis -> ppNoInline stNm - OneVis _ -> if aggressiveInlinePragmas @lhs.options - then ppInline stNm - else ppInlinable stNm - NoneVis -> if st /= @lhs.initial - then error ("State " ++ show st ++ " is not reachable from the initial state.") - else if aggressiveInlinePragmas @lhs.options - then ppInline stNm -- first state can be inlined - else ppInlinable stNm - else ppNoInline stNm - cCon = "C_" >|< @lhs.nt >|< "_s" >|< st - bang | st == @lhs.initial = @loc.addbang -- initial state is not parameterized - | otherwise = id - - -- note about the initial state: the initial state should be the only - -- state-binding that is not a function. It is non-recursive and not needed - -- anywhere except delivered as initial result. This binding therefore does - -- not end up needlessly in any closure. - in case nextVisitInfo of - NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced - -- thus generating it is not needed (and omitting it may catch some small mistakes). - if st == @lhs.initial - then lhs >#< cCon -- empty state - else empty -- no state generated - OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId) - ManyVis -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st) - loc.stargs = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap - in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str - | otherwise = @loc.addbang (pp str) - in case mbAttr of - Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> - case Map.lookup nm @loc.localAttrTypes of - Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) - Nothing -> match - Just attr | not (noPerStateTypeSigs @lhs.options) -> - case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of - Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) - Nothing -> match - _ -> match - | (str,mbAttr) <- Map.assocs attrs - ] >#< dummyPat @lhs.options (Map.null attrs) - - loc.stks = \st -> if null (@loc.stvisits st) - then empty - else ( if not (noInlinePragmas @lhs.options) && helpInlining @lhs.options - then ppNoInline ("k" >|< st) - else empty - ) - >-< "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "t" >#< "->" >#< "t" - >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "=" - >#< "v" >|< v) $ @loc.stvisits st) - loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits - loc.stvs = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st] - visits.mrules = @rules.mrules - -{ -mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc -mklet prefix defs body = - prefix >#< "let" - >-< indent 3 defs - >-< indent 2 "in" >#< body -} - -------------------------------------------------------------------------------- --- Visit semantic functions -------------------------------------------------------------------------------- -ATTR Visit [ | | sem_visit : { (StateIdentifier,Bool -> PP_Doc) } ] -ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ] - -SEM Visit - | Visit lhs.sem_visit = ( @from - , \addInlinePragma -> - ( if noInlinePragmas @lhs.options - then empty - else if addInlinePragma && aggressiveInlinePragmas @lhs.options - then ppInline @loc.vname - else if helpInlining @lhs.options - then ppNoInline @loc.vname - else empty - ) - >-< "v" >|< @ident >#< "::" >#< @loc.nameT_visit >#< @loc.t_params - - -- generate a lambda here as well instead of a function definition - >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats)) - >#< ( if dummyTokenVisit @lhs.options - then pp $ dummyPat @lhs.options True -- extra (but unused) argument - else empty - ) - >#< "->" - >#< ( if genCostCentres @lhs.options - then ppCostCentre (@loc.vname >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con) - else empty - ) >#< "(" >#< @loc.stepsInitial - >-< indent 3 (@steps.sem_steps >-< @loc.stepsClosing >#< ")") - ) - loc.stepsInitial = case @kind of - VisitPure False -> text "let" - VisitPure True -> empty - VisitMonadic -> text "do" - loc.stepsClosing = let decls = @loc.nextStBuild - >-< @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval - in case @kind of - VisitPure False -> decls - >-< "in" >#< resultValName - VisitPure True -> "let" >#< decls - >-< indent 1 ("in" >#< resultValName) - VisitMonadic -> "let" >#< decls - >-< "return" >#< resultValName - loc.vname = "v" >|< @ident - loc.inhpats = ppSpaced $ map (\arg -> {-@loc.addbang $-} pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh - loc.inhargs = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh - loc.synargs = ppSpaced $ map (\arg -> attrname @lhs.options False _LHS arg) $ Set.toList @syn - loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap - loc.nextargs = ppSpaced $ Map.keys $ @loc.nextargsMp - loc.nextst = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp) - loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef - (loc.nextStBuild, loc.nextStRef) - = case @loc.nextVisitInfo of - NoneVis -> (empty, empty) - _ -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName) - -{ -resultValName :: String -resultValName = "__result_" - -nextStName :: String -nextStName = "__st_" -} - --- Propagate the visit kind to the steps -ATTR VisitStep VisitSteps [ kind : VisitKind | | ] -SEM Visit | Visit steps.kind = @kind - --- the steps in this group should be executed in a pure fashion -SEM VisitStep | PureGroup - steps.kind = VisitPure @ordered - -ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ] -ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ] -SEM VisitStep - | Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules - (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of - Left e -> (Seq.singleton e, empty) - Right stmt -> (Seq.empty, stmt) - | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros - (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses) - = case @loc.attachItf @lhs.kind @lhs.fmtMode of - Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) - Right (code, defs, uses) -> (Seq.empty, code, defs, uses) - | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit - (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of - Left e -> (Seq.singleton e, empty, empty) - Right (pat,expr) -> (Seq.empty, pat, expr) - - loc.useParallel = @lhs.useParallel && not @lhs.isLast - lhs.sem_steps = if @loc.useParallel -- assumes to be in a monadic do-expression - then @loc.addbang ("sync_" >|< @lhs.index) >#< "<- newEmptyMVar" - >-< "forkIO" >#< pp_parens (@loc.convToMonad >#< pp_parens @loc.exprPP >#< ">>= \\" >#< @loc.addbang (pp parResultName) >#< " -> putMVar sync_" >|< @lhs.index >#< parResultName) -- parResultName is guaranteed to be evaluated - else let decl = case @lhs.kind of - VisitPure _ -> @loc.patPP >#< "=" >#< @loc.exprPP - VisitMonadic -> @loc.patPP >#< "<-" >#< @loc.exprPP - in fmtDecl False @lhs.fmtMode decl - loc.convToMonad = case @loc.callKind of - VisitPure _ -> text "return" - VisitMonadic -> empty - loc.callKind = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds - | Sim lhs.sem_steps = @steps.sem_steps >-< @steps.sync_steps - | PureGroup lhs.sem_steps = case @lhs.fmtMode of - FormatDo -> "let" >#< @steps.sem_steps -- formatted as a let-block (not a line-let) - _ -> @steps.sem_steps - -ATTR VisitSteps VisitStep [ | | sync_steps USE {>-<} {empty} : {PP_Doc} ] -SEM VisitStep | ChildVisit - lhs.sync_steps = if @loc.useParallel - then @loc.patPP >#< "<-" >#< "takeMVar sync_" >|< @lhs.index - else empty - --- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing --- declarations, because that determines how we need to wrap declarations --- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo -ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ] -SEM Visit | Visit - steps.fmtMode = case @kind of - VisitPure False -> FormatLetDecl - VisitPure True -> FormatLetLine - VisitMonadic -> FormatDo - -SEM VisitStep | PureGroup - steps.fmtMode = case @lhs.fmtMode of - FormatDo -> FormatLetDecl - mode -> mode - -{ -parResultName :: String -parResultName = "__outcome_" - -fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc -fmtDecl declPure fmt decl = case fmt of - FormatLetDecl -> pp decl - FormatLetLine -> "let" >#< decl >#< "in" - FormatDo | declPure -> "let" >#< decl - | otherwise -> pp decl -} - --- --- Some properties of VisitStep(s) --- - --- Used arguments -ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ] -SEM ERule - | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs - -SEM EChild - | EChild +usedArgs = \s -> case @kind of - ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s - _ -> s - - --- Number of steps in a 'Sim' block -ATTR VisitSteps [ | | size : Int ] -SEM VisitSteps - | Nil lhs.size = 0 - | Cons lhs.size = 1 + @tl.size - --- Number the steps in a 'Sim' block -ATTR VisitSteps VisitStep [ | index : Int | ] -SEM VisitSteps | Cons - hd.index = @lhs.index -- copy rule - tl.index = 1 + @lhs.index - lhs.index = @tl.index -- copy rule -SEM Visit | Visit steps.index = 0 -SEM VisitStep | Sim steps.index = 0 - lhs.index = @lhs.index -- needed for if we ever allow nested Sims - --- Biggest number of steps in previous blocks that used parallel invocation --- This number - 1 (minimum 0) is the number of references for parallel invocation created -ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ] -SEM Visit | Visit steps.prevMaxSimRefs = 0 -SEM VisitStep | Sim - lhs.prevMaxSimRefs = if @loc.useParallel - then @lhs.prevMaxSimRefs `max` (@steps.index - 1) -- possibly new references made - else @lhs.prevMaxSimRefs -- no references created - --- Is this the last step? -ATTR VisitSteps VisitStep [ | | isLast : Bool ] -ATTR VisitStep [ isLast : Bool | | ] -SEM VisitSteps - | Nil lhs.isLast = True - | Cons lhs.isLast = False - hd.isLast = @tl.isLast - --- Use parallel invocation: only when option enabled and there is more than one visit to a child -SEM VisitSteps VisitStep [ useParallel : Bool | | ] -SEM Visit | Visit steps.useParallel = False -SEM VisitStep | Sim loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1 && @loc.isMonadic - loc.isMonadic = case @lhs.kind of - VisitMonadic -> True - _ -> False - - --- Child introduction -ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ] - -ATTR Visits Visit - VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ] - -SEM EProduction - | EProduction visits.childintros = @children.childintros - -SEM EChild - | ETerm lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty)) - | EChild lhs.childintros = Map.singleton @name @loc.introcode - loc.isDefor = case @tp of - NT _ _ defor -> defor - _ -> False - loc.valcode = case @kind of - ChildSyntax -> "arg_" >|< @name >|< "_" - ChildAttr -> -- decide if we need to invoke the sem-function under the hood - let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options -- when sepsemmods is not enabled, the indirection can be optimized away - then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr - else "sem_" >|< @loc.nt - | otherwise = empty -- no need to intro a terminal - in pp_parens (prefix >#< instname @name) - ChildReplace _ -> -- the higher-order attribute is actually a function that transforms - -- the semantics of the child (always deforested) - pp_parens (instname @name >#< @name >|< "_") - loc.aroundcode = if @hasAround - then locname @lhs.options @name >|< "_around" - else empty - loc.introcode = \kind fmtMode -> - let pat = text $ stname @name @loc.initSt - patStrict = @loc.addbang pat - attach = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode) - runAttach = unMon @lhs.options >#< pp_parens attach - decl = case kind of - VisitPure False -> pat >#< "=" >#< runAttach - VisitPure True -> patStrict >#< "=" >#< runAttach - VisitMonadic -> patStrict >#< "<-" >#< attach - in if compatibleAttach kind @loc.nt @lhs.options - then Right ( fmtDecl False fmtMode decl - , Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro - , case @kind of -- variables used by the child introduction - ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr - ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options) - then id -- the sem dictionary attr is not used - else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) - ) $ - ( if @hasAround - then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing - else id - ) $ Map.empty - ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function - ChildSyntax -> Map.empty - ) - else Left $ IncompatibleAttachKind @name kind - loc.nt = extractNonterminal @tp - -{ -stname :: Identifier -> Int -> String -stname child st = "_" ++ getName child ++ "X" ++ show st - --- should actually return some conversion info -compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool -compatibleAttach _ _ _ = True - -unMon :: Options -> PP_Doc -unMon options - | parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO" -- IO monad - | otherwise = text "Control.Monad.Identity.runIdentity" -- identity monad -} - --- rules -ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc} - mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ] - -SEM ERule | ERule - lhs.sem_rules = if @loc.used == 0 - then empty - else @loc.rulePragma >-< @loc.rulecode - loc.rulecode = ( if @loc.genpragma - then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of - -- type errors in the rule. It will definitely not be precise, and may take some additional - -- source space, but let's see if it's worth it in practice. - else empty - ) - >-< @loc.lambda >#< @loc.scc - >-< indent ((column @rhs.pos - 2) `max` 2) - ( if @loc.genpragma - then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma - else @rhs.semfunc - ) - loc.rulePragma = ( let reallyInlineStr = "INLINE" - reallyNoInlineStr = "NOINLINE" - in if noInlinePragmas @lhs.options - then empty - else if @loc.used == 1 - then ppPragmaBinding reallyInlineStr @name -- always inline if used exactly once - else if helpInlining @lhs.options - then if not @explicit && @loc.used <= reallyOftenUsedThreshold - then ppPragmaBinding "INLINE[1]" @name -- inline if copy rule - else if @loc.used > ruleInlineThresholdSoft && @explicit -- noinline if it passes the threshold and is not a copy rule - then if @loc.used > ruleInlineThresholdHard - then ppPragmaBinding reallyNoInlineStr @name -- used too often: force ghc not to inline it - else if aggressiveInlinePragmas @lhs.options - then ppPragmaBinding "NOINLINE[2]" @name -- allow inlining but only late in the process - else ppNoInline @name - else if aggressiveInlinePragmas @lhs.options - then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first) - else ppNoInline @name - else if not @explicit || @loc.used <= ruleInlineThresholdSoft - then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first) - else ppNoInline @name - ) - loc.scc = if genCostCentres @lhs.options && @explicit && @pure && not (noPerRuleCostCentres @lhs.options) - then ppCostCentre (@name >|< "_" >|< line @rhs.pos >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con) - else empty - loc.pragma = "{-# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#-}" - loc.endpragma = ppWithLineNr (\ln -> "{-# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#-}") - loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos - loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos)) - - -- we generate a simple pattern binding because of overloading-resolving during the type inference process. - -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context). - -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have - -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead - -- of a function definition. - -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures - -- but are lambda-lifted instead. - loc.lambda = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->" - - loc.argPats = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str - | otherwise = @loc.addbang1 (pp str) - in case mbAttr of - Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> - case Map.lookup nm @lhs.localAttrTypes of - Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) - Nothing -> match - Just attr | not (noPerRuleTypeSigs @lhs.options) -> - case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of - Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) - Nothing -> match - _ -> match - | (str,mbAttr) <- Map.assocs @rhs.attrs - ] - loc.argExprs = ppSpaced [ case mbAttr of - Nothing -> "arg_" >|< str - _ -> text str - | (str,mbAttr) <- Map.assocs @rhs.attrs - ] - loc.stepcode = \kind fmtMode -> if kind `compatibleRule` @pure - then Right $ let oper | @pure = "=" - | otherwise = "<-" - decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs) - tp = if @pure && not (noPerRuleTypeSigs @lhs.options) - then @pattern.attrTypes - else empty - in fmtDecl @pure fmtMode (tp >-< decl) - else Left $ IncompatibleRuleKind @name kind - - lhs.mrules = Map.singleton @name @loc.stepcode - -ATTR Expression [ | | tks : {[HsToken]} ] -SEM Expression - | Expression lhs.tks = @tks - -{ -dummyPat :: Options -> Bool -> PP_Doc -dummyPat opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = if strictDummyToken opts - then text "()" - else text "(_ :: ())" - | otherwise = let match | strictDummyToken opts = "!_" - | otherwise = "_" - in pp_parens (match >#< "::" >#< dummyType opts noArgs) - where match | strictDummyToken opts = "(!_)" - | otherwise = "_" - -dummyArg :: Options -> Bool -> PP_Doc -dummyArg opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = text "()" - | otherwise = text "GHC.Prim.realWorld#" - -dummyType :: Options -> Bool -> PP_Doc -dummyType opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = text "()" - | otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)" -} - -{ --- rules are "deinlined" to prevent needless code duplication. --- if there is only a bit of duplication, we allow ghc to decide if it is worth it. --- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it. -ruleInlineThresholdSoft :: Int -ruleInlineThresholdSoft = 3 - -ruleInlineThresholdHard :: Int -ruleInlineThresholdHard = 5 - -reallyOftenUsedThreshold :: Int -reallyOftenUsedThreshold = 12 -} - -ATTR Expression [ | | pos : {Pos} ] -SEM Expression | Expression lhs.pos = @pos - --- pattern and expression semantics -ATTR Pattern [ | | sem_lhs : { PP_Doc } ] -ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ] -ATTR Pattern Patterns [ | | ] - -SEM Pattern - | Alias loc.varPat = text $ attrname @lhs.options False @field @attr - loc.patExpr = if @pat.isUnderscore - then @loc.varPat - else @loc.varPat >|< "@" >|< @pat.sem_lhs - lhs.sem_lhs = @loc.addbang1 @loc.patExpr - | Product lhs.sem_lhs = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs - | Constr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs - | Underscore lhs.sem_lhs = text "_" - | Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs - --- Check if a pattern is just an underscore -ATTR Pattern [ | | isUnderscore:{Bool}] -SEM Pattern - | Constr lhs.isUnderscore = False - | Product lhs.isUnderscore = False - | Alias lhs.isUnderscore = False - | Underscore lhs.isUnderscore = True - --- Collect the attributes defined by a pattern -ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ] -SEM Pattern | Alias - lhs.attrs = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs - --- All attribute types of this pattern -ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ] -SEM Pattern | Alias - loc.mbTp = if @field == _LHS - then Map.lookup @attr @lhs.synmap - else if @field == _LOC - then Map.lookup @attr @lhs.localAttrTypes - else Nothing - lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp - >-< @pat.attrTypes - --- Collect the attributes used by the right-hand side -ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] -SEM HsToken - | AGLocal lhs.attrs = Map.singleton (fieldname @var) Nothing - | AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST' - then Nothing -- should not be used in the first place - else Just $ mkNonLocalAttr (@field == _LHS) @field @attr - lhs.attrs = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr - -{ -data NonLocalAttr - = AttrInh Identifier Identifier - | AttrSyn Identifier Identifier deriving Show - -mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr -mkNonLocalAttr True = AttrInh -- True: inherited attr -mkNonLocalAttr False = AttrSyn - -lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs -lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns - --- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that --- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. --- However, for now we simply decide to return Nothing in this case, which skips the type annotation. -lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupType child name attrMp childMp - | noParameters childTp = Just ppDoc - | otherwise = Nothing - where - attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs - childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp - nonterm = extractNonterminal childTp - childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp - ppDoc = ppTp attrTp - -noParameters :: Type -> Bool -noParameters (Haskell _) = True -noParameters (NT _ args _) = null args -} - -ATTR Expression [ | | semfunc : {PP_Doc} ] - -SEM Expression - | Expression lhs.attrs = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks - lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks - loc.inhhstoken = Inh_HsToken @lhs.options - --- child visit map -ATTR Visit - Visits - EProduction - EProductions - ENonterminal - ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} - | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ] - -ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.allchildvisit = @nonts.childvisit - -SEM Visit - | Visit - loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits - lhs.childvisit = Map.singleton @ident @loc.invokecode - loc.invokecode = \chn kind -> -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit - if kind `compatibleKind` @kind - then Right $ - let pat | isLazyKind @kind = pat0 - | otherwise = @loc.addbang pat0 - pat0 = pp_parens pat1 - pat1 = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname @lhs.options True chn) $ Set.toList @syn) - >#< cont - cont = case @loc.nextVisitInfo of - NoneVis -> empty - _ -> ch1 - ch0 = text $ stname chn @from - ch1 = text $ stname chn @to - expr = case (kind, @kind) of - (VisitPure _, VisitPure _) -> expr0 - (VisitPure _, VisitMonadic) -> unMon @lhs.options >#< expr0 - (VisitMonadic, VisitPure _) -> "return" >#< expr0 - (VisitMonadic, VisitMonadic) -> expr0 - expr0 = case @loc.prevVisitInfo of - NoneVis -> error "error: invocation of a visit from a state that has no next visits" - OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args - ManyVis -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 - >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args - args = pp_parens args0 >#< args1 - args0 = @loc.nameTIn_visit >#< @loc.inhargs chn - args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True - | otherwise = empty - in (pat, expr) -- pretty print of the pattern and the expression part - else Left $ IncompatibleVisitKind chn @ident kind @kind - -{ --- a `compatibleKind` b means: can kind b be invoked from a -compatibleKind :: VisitKind -> VisitKind -> Bool -compatibleKind _ _ = True - -compatibleRule :: VisitKind -> Bool -> Bool -compatibleRule (VisitPure _) False = False -compatibleRule _ _ = True -} - -------------------------------------------------------------------------------- --- Properties of rules -------------------------------------------------------------------------------- - --- Construct an environment that counts how often certain rules are used -ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ] -ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ] - -SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage -SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1 -SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo - -{ -unionWithSum = Map.unionWith (+) -} - --- Collect in what visit-kinds a rule is used -ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ] -SEM VisitStep | Sem - lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind) - -ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ] -SEM EProduction | EProduction - rules.ruleKinds = @visits.ruleKinds - -SEM ERule | ERule - loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds - loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds - -ATTR Pattern Patterns [ anyLazyKind : Bool | | ] - - -------------------------------------------------------------------------------- --- Intra attributes -------------------------------------------------------------------------------- -{ -uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) -uwSetUnion = Map.unionWith Set.union - -uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) -uwMapUnion = Map.unionWith Map.union -} -ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} - | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ] - -ATTR Visit Visits [ terminaldefs : {Set String} | | ] -ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ] - -SEM EChild | ETerm - lhs.terminaldefs = Set.singleton $ fieldname @name - -SEM EProduction | EProduction - visits.allintramap = @visits.intramap - visits.terminaldefs = @children.terminaldefs - -SEM Visit - | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap - lhs.intramap = Map.singleton @from @loc.thisintra - loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap - loc.uses = let mp1 = @steps.uses - mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ] - in mp1 `Map.union` mp2 - loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh - loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs - loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ] - -ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)} - ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ] -ATTR Visit Visits - VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)} - ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ] - -SEM ERule - | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs - lhs.ruleuses = Map.singleton @name @rhs.attrs - -SEM EProduction - | EProduction visits.ruledefs = @rules.ruledefs - visits.ruleuses = @rules.ruleuses - -ATTR Visit Visits - EProduction - EProductions - ENonterminal - ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} - visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ] - -SEM Visit - | Visit lhs.visitdefs = Map.singleton @ident @syn - lhs.visituses = Map.singleton @ident @inh - -ATTR Visit Visits - VisitSteps VisitStep - EProduction EProductions - ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)} - avisituses : {Map VisitIdentifier (Set Identifier)} | | ] - -SEM ExecutionPlan - | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs - nonts.avisituses = @nonts.visituses - -ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String} - uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] -SEM VisitStep - | Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs - lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses - | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs - lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ] - in Map.insert (stname @child @from) Nothing $ convert $ - maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses - -------------------------------------------------------------------------------- --- Identification of lazy intra defs within a production --- --- These identifiers will not be marked as strict in rules and state closures -------------------------------------------------------------------------------- - -ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ] -ATTR ERules ERule [ lazyIntras : {Set String} | | ] - -SEM Visit | Visit - loc.lazyIntrasInh = case @kind of - VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs - _ -> Set.empty - lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras - -SEM VisitStep | PureGroup - lhs.lazyIntras = if @ordered - then @steps.lazyIntras - else @steps.defs - -SEM EProduction | EProduction - loc.lazyIntras = @visits.lazyIntras - -------------------------------------------------------------------------------- --- Pretty printing of haskell code -------------------------------------------------------------------------------- - -SEM HsTokens [ || tks : {[(Pos,String)]} ] - | Cons lhs.tks = @hd.tok : @tl.tks - | Nil lhs.tks = [] - -SEM HsToken - | AGLocal loc.tok = (@pos,fieldname @var) - -SEM HsToken [ || tok:{(Pos,String)}] - | AGField - loc.addTrace = case @rdesc of - Just d -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))" - Nothing -> id - lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr) - - | HsToken lhs.tok = (@pos, @value) - - | CharToken lhs.tok = (@pos, if null @value - then "" - else showCharShort (head @value) - ) - - | StrToken lhs.tok = (@pos, showStrShort @value) - | Err lhs.tok = (@pos, "") - -------------------------------------------------------------------------------- --- Alternative code generation (sepsemmods) -------------------------------------------------------------------------------- - -ATTR ExecutionPlan [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc} - | | genIO : {IO ()} ] - -SEM ExecutionPlan - | ExecutionPlan lhs.genIO = do @loc.genMainModule - @loc.genCommonModule - @nonts.genProdIO - loc.mainModuleFile = @lhs.mainFile - loc.ppMonadImports = ( if tupleAsDummyToken @lhs.options - then empty - else pp "import GHC.Prim" - ) - >-< if parallelInvoke @lhs.options - then pp "import qualified System.IO.Unsafe(unsafePerformIO)" - >-< pp "import System.IO(IO)" - >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)" - else pp "import Control.Monad.Identity" - loc.genMainModule = writeModule @loc.mainModuleFile - ( [ warrenFlagsPP @lhs.options - , pp $ @lhs.pragmaBlocks - , pp $ @lhs.moduleHeader @lhs.mainName "" "" False - , @loc.ppMonadImports - , pp $ "import " ++ @lhs.mainName ++ "_common" - ] - ++ @nonts.imports - ++ [@lhs.mainBlocksDoc] - ++ [@loc.wrappersExtra] - ++ @nonts.appendMain - ) - loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") - loc.genCommonModule = writeModule @loc.commonFile - ( [ pp $ "{-# LANGUAGE Rank2Types, GADTs #-}" -- the common module only needs GADTs and Rank2Types - , pp $ @lhs.pragmaBlocks - , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True - , @loc.ppMonadImports - , @lhs.importBlocks - , @lhs.textBlocks - , @loc.commonExtra - ] - ++ @nonts.appendCommon - ) - -ATTR ENonterminal [ | | appendCommon, appendMain : { PP_Doc } ] -ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ] - -SEM ENonterminal - | ENonterminal lhs.appendMain = (if @nt `Set.member` @lhs.wrappers - then @loc.wr_inh - >-< @loc.wr_syn - >-< @loc.wrapper - else empty) - >-< @loc.sem_nt - lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty) - >-< @loc.t_init - >-< @loc.t_states - >-< @loc.k_states - >-< @prods.t_visits - -ATTR EProduction EProductions - ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]} - genProdIO USE {>>} {return ()} : {IO ()} ] - -SEM EProduction - | EProduction lhs.imports = [pp $ "import " ++ @loc.moduleName] - loc.moduleName = @lhs.mainName ++ @loc.suffix - loc.suffix = "_" ++ show @lhs.nt ++ "_" ++ show @con - loc.outputfile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix) - loc.ppMonadImports = if parallelInvoke @lhs.options - then pp "import qualified System.IO.Unsafe(unsafePerformIO)" - >-< pp "import System.IO(IO)" - >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)" - else pp "import Control.Monad.Identity" - lhs.genProdIO = writeModule @loc.outputfile - [ warrenFlagsPP @lhs.options - , pp $ @lhs.pragmaBlocks - , pp $ @lhs.moduleHeader @lhs.mainName @loc.suffix @loc.semname True - , @lhs.importBlocks - , @loc.ppMonadImports - , ( if tupleAsDummyToken @lhs.options - then empty - else pp "import GHC.Prim" -- need it to pass State# - ) - , pp $ "import " ++ @lhs.mainName ++ "_common" - , @loc.sem_prod - ] - -{ -renderDocs :: [PP_Doc] -> String -renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" - -writeModule :: FilePath -> [PP_Doc] -> IO () -writeModule path docs - = do bExists <- doesFileExist path - if bExists - then do input <- readFile path - seq (length input) (return ()) - if input /= output - then dumpIt - else return () - else dumpIt - where - output = renderDocs docs - dumpIt = writeFile path output -} - - --- --- Bang pattern usage --- - -SEM ERule | ERule loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM Visit | Visit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM ENonterminal | ENonterminal loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM EProduction | EProduction loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM EChild | EChild loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM EChild | ETerm loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM VisitStep | ChildVisit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM Pattern | Alias Constr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x - -SEM Visit | Visit loc.addbang1 = if isLazyKind @kind then id else @loc.addbang -SEM ENonterminal | ENonterminal loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id -SEM ERule | ERule loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang -SEM Pattern | Alias Constr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang - --- --- Distribute single-visit-next map downward --- - -ATTR EProductions EProduction Visits Visit - [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ] - -SEM ENonterminal | ENonterminal - prods.nextVisits = @nextVisits - prods.prevVisits = @prevVisits - --- --- Collect and distribute the from/to states of a visit --- - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit - [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ] - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep - [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ] - -SEM Visit | Visit - lhs.fromToStates = Map.singleton @ident (@from, @to) - -SEM ExecutionPlan | ExecutionPlan - nonts.allFromToStates = @nonts.fromToStates - -SEM VisitStep | ChildVisit - (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates - - --- --- Collect and distribute the actual types of children of productions --- - -ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ] -ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ] - -SEM EProduction | EProduction - loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes - -SEM EChild | EChild ETerm - lhs.childTypes = Map.singleton @name @tp - --- --- Distribute types of local attributes --- - -ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ] -ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ] -ATTR ERules ERule Pattern Patterns [ localAttrTypes : {Map Identifier Type} | | ] - -SEM ENonterminal | ENonterminal - prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes - -SEM EProduction | EProduction - loc.localAttrTypes = Map.findWithDefault Map.empty @con @lhs.localAttrTypes - --- --- Collect and distribute visit kinds --- - -ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep - [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ] - -SEM Visit | Visit - lhs.visitKinds = Map.singleton @ident @kind - -SEM ExecutionPlan | ExecutionPlan - nonts.allVisitKinds = @nonts.visitKinds - --- --- Collect and distribute the initial state of nonterminals --- - -ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ] -ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep - [ allInitStates : {Map NontermIdent Int} | | ] - -SEM ENonterminal | ENonterminal - lhs.initStates = Map.singleton @nt @initial - -SEM ExecutionPlan | ExecutionPlan - nonts.allInitStates = @nonts.initStates - -SEM EChild | EChild - loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates - --- --- Push the nonterminal type downward --- - -ATTR EProductions EProduction [ ntType : Type | | ] -SEM ENonterminal | ENonterminal - loc.ntType = NT @nt (map show @params) False - --- --- Collect errors contained in rules that should be yielded when the --- rules are scheduled. --- - -ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] -SEM ERule | ERule - lhs.errors = case @mbError of - Just e | @loc.used > 0 -> Seq.singleton e - _ -> Seq.empty - - --- Some pretty printing utility functions -{ -ppNoInline :: PP a => a -> PP_Doc -ppNoInline = ppPragmaBinding "NOINLINE" - -ppInline :: PP a => a -> PP_Doc -ppInline = ppPragmaBinding "INLINE" - -ppInlinable :: PP a => a -> PP_Doc -ppInlinable = ppPragmaBinding "INLINABLE" - -ppPragmaBinding :: (PP a, PP b) => a -> b -> PP_Doc -ppPragmaBinding pragma nm = "{-#" >#< pragma >#< nm >#< "#-}" - -ppCostCentre :: PP a => a -> PP_Doc -ppCostCentre nm = "{-#" >#< "SCC" >#< "\"" >|< nm >|< "\"" >#< "#-}" - -warrenFlagsPP :: Options -> PP_Doc -warrenFlagsPP options = vlist - [ pp "{-# LANGUAGE Rank2Types, GADTs #-}" - , if bangpats options - then pp "{-# LANGUAGE BangPatterns #-}" - else empty - , if noPerRuleTypeSigs options && noPerStateTypeSigs options - then empty - else pp "{-# LANGUAGE ScopedTypeVariables #-}" - , if tupleAsDummyToken options - then empty - else pp "{-# LANGUAGE ScopedTypeVariables, MagicHash #-}" - , -- not that the meaning of "unbox" is here that strict fields in data types may be - -- unboxed if possible. This may affect user-defined data types declared in the module. - -- Unfortunately, we cannot turn it on for only the AG generated data types without - -- causing a zillion of warnings. - if unbox options && bangpats options - then pp $ "{-# OPTIONS_GHC -funbox-strict-fields -fstrictness #-}" - else empty - , if parallelInvoke options && not (noEagerBlackholing options) - then pp $ "{-# OPTIONS_GHC -feager-blackholing #-}" - else empty - ] -} +INCLUDE "ExecutionPlan.ag" +INCLUDE "Patterns.ag" +INCLUDE "Expression.ag" +INCLUDE "HsToken.ag" + +imports +{ +import ExecutionPlan +import Pretty +import PPUtil +import Options +import Data.Monoid(mappend,mempty) +import Data.Maybe +import Debug.Trace +import System.IO +import System.Directory +import System.FilePath +import UU.Scanner.Position + +import TokenDef +import HsToken +import ErrorMessages + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Sequence(Seq) +import qualified Data.Sequence as Seq +import Data.Foldable(toList) +} + +ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild + [ importBlocks : PP_Doc + pragmaBlocks : String + textBlocks : PP_Doc + moduleHeader : {String -> String -> String -> Bool -> String} + mainFile : String + mainName : String | | ] + +------------------------------------------------------------------------------- +-- Options +------------------------------------------------------------------------------- +ATTR ExecutionPlan + ENonterminals ENonterminal + EProductions EProduction + ERules ERule + EChildren EChild + Expression + HsToken HsTokens HsTokensRoot + Pattern Patterns + Visits Visit + VisitSteps VisitStep [ options : {Options} | | ] +ATTR EProductions EProduction [ rename : {Bool} | | ] + +SEM ENonterminal + | ENonterminal prods.rename = rename @lhs.options + +------------------------------------------------------------------------------- +-- Context info (nonterminal ident, constructor ident, nonterm params, etc.) +------------------------------------------------------------------------------- + +ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ] +SEM ENonterminal + | ENonterminal prods.nt = @nt + +ATTR EChildren EChild ERules ERule Visits Visit + [ con : ConstructorIdent | | ] + +SEM EProduction + | EProduction children.con = @con + rules.con = @con + visits.con = @con + +ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ] +SEM ENonterminal | ENonterminal + prods.params = @params + +ATTR EProductions EProduction [ classCtxs : ClassContext | | ] +SEM ENonterminal | ENonterminal + prods.classCtxs = @classCtxs + +------------------------------------------------------------------------------- +-- Default output +------------------------------------------------------------------------------- +ATTR ExecutionPlan [ | | output : {PP_Doc} ] + +SEM ExecutionPlan + | ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra + +ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent} + | | output USE {>-<} {empty} : {PP_Doc} ] + +SEM ExecutionPlan + | ExecutionPlan nonts.wrappers = @wrappers + +SEM ENonterminal + | ENonterminal lhs.output = ("-- " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-') + >-< (if dataTypes @lhs.options + then "-- data" + >-< @loc.datatype + >-< "" + else empty) + >-< (if @loc.hasWrapper + then "-- wrapper" + >-< @loc.wr_inh + >-< @loc.wr_syn + >-< @loc.wrapper + >-< "" + else empty) + >-< (if folds @lhs.options + then "-- cata" + >-< @loc.sem_nt + >-< "" + else empty) + >-< (if semfuns @lhs.options + then "-- semantic domain" + >-< @loc.t_init + >-< @loc.t_states + >-< @loc.k_states + >-< @prods.t_visits + >-< @prods.sem_prod + >-< "" + else empty) + loc.hasWrapper = @nt `Set.member` @lhs.wrappers + +------------------------------------------------------------------------------- +-- Nonterminal datatype +------------------------------------------------------------------------------- +ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns} + derivings : {Derivings} | | ] + +SEM ExecutionPlan + | ExecutionPlan nonts.typeSyns = @typeSyns + nonts.derivings = @derivings + +SEM ENonterminal + | ENonterminal loc.classPP = ppClasses $ classCtxsToDocs @classCtxs + loc.aliasPre = "type" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "=" + loc.datatype = case lookup @nt @lhs.typeSyns of + Nothing -> "data" >#< @loc.classPP >#< @nt >#< @loc.t_params + >-< ( if null @prods.datatype + then empty + else indent 2 $ vlist $ ( ("=" >#< head @prods.datatype) + : (map ("|" >#<) $ tail @prods.datatype)) + ) + >-< indent 2 @loc.derivings + Just (List t) -> @loc.aliasPre >#< "[" >#< show t >#< "]" + Just (Maybe t) -> @loc.aliasPre >#< "Maybe" >#< pp_parens (show t) + Just (Tuple ts) -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts) + Just (Either l r) -> @loc.aliasPre >#< "Either" >#< pp_parens (show l) >#< pp_parens (show r) + Just (Map k v) -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v) + Just (IntMap t) -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t) + Just (OrdSet t) -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (show t) + Just IntSet -> @loc.aliasPre >#< "Data.IntSet.IntSet" +-- Just x -> error $ "Type " ++ show x ++ " is not supported" + loc.derivings = case Map.lookup @nt @lhs.derivings of + Nothing -> empty + Just s -> if Set.null s + then empty + else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s) + +{ +classCtxsToDocs :: ClassContext -> [PP_Doc] +classCtxsToDocs = map toDoc where + toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args)) + +classConstrsToDocs :: [Type] -> [PP_Doc] +classConstrsToDocs = map ppTp + +ppClasses :: [PP_Doc] -> PP_Doc +ppClasses [] = empty +ppClasses xs = pp_block "(" ")" "," xs >#< "=>" + +ppQuants :: [Identifier] -> PP_Doc +ppQuants [] = empty +ppQuants ps = "forall" >#< ppSpaced ps >#< "." +} + +ATTR EProduction [ | | datatype : {PP_Doc} ] +ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} ] + +-- we generate the data type in the type-class style instead of the GADT style +-- the GADT extension may be required if equality constraints are used +SEM EProduction + | EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1 + >#< conname @lhs.rename @lhs.nt @con + >#< ppConFields (dataRecords @lhs.options) @children.datatype + loc.classPP1 = ppClasses (classConstrsToDocs @constraints) + loc.quantPP1 = ppQuants @params + +{ +-- first parameter indicates: generate a record or not +ppConFields :: Bool -> [PP_Doc] -> PP_Doc +ppConFields True flds = ppListSep "{" "}" ", " $ filter (not . isEmpty) flds +ppConFields False flds = ppSpaced flds +} + + +ATTR EChild [ | | datatype : {PP_Doc} ] +ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]} ] + +-- Note: the child may be a higher-order attribute, and its semantics may be deforested +SEM EChild + | EChild ETerm + loc.tpDoc = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp + loc.strNm = recordFieldname @lhs.nt @lhs.con @name + loc.field = if dataRecords @lhs.options + then @loc.strNm >#< "::" >#< @loc.tpDoc + else @loc.tpDoc + loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x + | EChild lhs.datatype = case @kind of + ChildAttr -> empty -- higher order attributes are not part of the data type + _ -> @loc.field + + | ETerm lhs.datatype = @loc.field + +{ +ppTp :: Type -> PP_Doc +ppTp = text . typeToHaskellString Nothing [] +} + +------------------------------------------------------------------------------- +-- Nonterminal semantic function +------------------------------------------------------------------------------- +SEM ENonterminal + | ENonterminal loc.fsemname = \x -> "sem_" ++ show x + loc.semname = @loc.fsemname @nt + loc.frecarg = \t x -> case t of + NT nt _ _ -> pp_parens (@fsemname nt >#< x) + _ -> pp x + + -- The sem_NT function is lazy in the AST: it depends on the application of "child" + -- rules to which extend the AST needs to be constructed. + loc.sem_tp = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params + loc.quantPP = ppQuants @params + loc.sem_nt = @loc.semPragma + >-< @loc.semname >#< "::" >#< @loc.sem_tp + >-< case lookup @nt @lhs.typeSyns of + Nothing -> @prods.sem_nt + Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Cons" + >#< @loc.semname >|< "_Nil" + >#< case t of + NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt >#< "list") + _ -> pp "list" + Just (Maybe t) -> @loc.semname >#< "Prelude.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing" + >-< @loc.semname >#< pp_parens ("Prelude.Just just") >#< "=" + >#< @loc.semname >|< "_Just" >#< @frecarg t "just" + Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "=" + >#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts) + Just (Either l r) -> @loc.semname >#< "(Prelude.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left" + >-< @loc.semname >#< "(Prelude.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right" + Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "Data.Map.foldrWithKey" + >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" + >#< case v of + NT nt _ _ -> pp_parens ("Data.Map.map" >#< @fsemname nt >#< "m") + _ -> pp "m" + Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "Data.IntMap.foldWithKey" + >#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil" + >#< case v of + NT nt _ _ -> pp_parens ("Data.IntMap.map" >#< @fsemname nt >#< "m") + _ -> pp "m" + Just (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry" + >#< @loc.semname >|< "_Nil" + >#< pp_parens ( + ( case t of + NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt) + _ -> empty + ) >#< pp_parens ("Data.IntSet.elems" >#< "s") + ) + Just IntSet -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry" + >#< @loc.semname >|< "_Nil" + >#< pp_parens ("Data.IntSet.elems" >#< "s") +-- Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns + + -- precise inlining strategies for inlining + loc.inlineNt = not (lateHigherOrderBinding @lhs.options) && not @recursive && (@prods.count == 1 || (aggressiveInlinePragmas @lhs.options && not @loc.hasWrapper)) -- lucrative for inlining + loc.semPragma = if noInlinePragmas @lhs.options + then empty + else if @loc.inlineNt + then ppInline @loc.semname + else if helpInlining @lhs.options && not (lateHigherOrderBinding @lhs.options) + then ppInlinable @loc.semname + else ppNoInline @loc.semname + +-- The number of productions +ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ] +SEM EProduction | EProduction lhs.count = {1} + +-- The per-production cases for the sem_NT function +ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ] +SEM EProduction + | EProduction lhs.sem_nt = "sem_" >|< @lhs.nt >#< "(" >#< conname @lhs.rename @lhs.nt @con >#< ppSpaced @children.argpats >#< ")" + >#< "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw + +ATTR EChild [ | | argnamesw : { PP_Doc } ] +ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ] + +SEM EChild + | EChild lhs.argnamesw = case @kind of + ChildSyntax -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")" + ChildAttr -> empty -- no sem-case for a higher-order child + ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")" + | ETerm lhs.argnamesw = text $ fieldname @name + +------------------------------------------------------------------------------- +-- Types of attributes +------------------------------------------------------------------------------- +ATTR ExecutionPlan + ENonterminals + ENonterminal [ inhmap : {Map NontermIdent Attributes} + synmap : {Map NontermIdent Attributes} | | ] + +ATTR EProductions EProduction + ERules ERule + Patterns Pattern + Visits + Visit [ inhmap : {Attributes} + synmap : {Attributes} + allInhmap : {Map NontermIdent Attributes} + allSynmap : {Map NontermIdent Attributes} | | ] + +SEM ENonterminal + | ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap + (Just prods.synmap) = Map.lookup @nt @lhs.synmap + prods.allInhmap = @lhs.inhmap + prods.allSynmap = @lhs.synmap + +------------------------------------------------------------------------------- +-- State datatypes +------------------------------------------------------------------------------- +{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)} + +ATTR Visit [ | | allvisits : { VisitStateState }] +ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}] +ATTR EProduction + EProductions [ | | allvisits: {[VisitStateState]}] + +SEM Visit + | Visit lhs.allvisits = (@ident, @from, @to) + +SEM EProductions + | Cons lhs.allvisits = @hd.allvisits -- just pick the first production + | Nil lhs.allvisits = error "Every nonterminal should have at least 1 production" + +-- type of tree in a given state s +SEM ENonterminal + | ENonterminal loc.outedges = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits + loc.inedges = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits + loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges + loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits + loc.t_type = "T_" >|< @nt + loc.t_params = ppSpaced @params + loc.t_init = "newtype" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type >#< + pp_braces ( + "attach_">|< @loc.t_type >#< "::" + >#< ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params)) + loc.t_states = vlist $ map (\st -> + let nt_st = @nt >|< "_s" >|< st + t_st = "T_" >|< nt_st + k_st = "K_" >|< nt_st + c_st = "C_" >|< nt_st + inv_st = "inv_" >|< nt_st + nextVisit = Map.findWithDefault ManyVis st @nextVisits + in case nextVisit of + NoneVis -> "data" >#< t_st >#< @loc.t_params >#< "=" >#< c_st -- empty semantics + OneVis vId -> "newtype" >#< t_st >#< @loc.t_params >#< "=" >#< c_st + >#< (pp_braces $ inv_st >#< "::" >#< pp_parens (conNmTVisit @nt vId >#< @loc.t_params)) + ManyVis -> "data" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::" + >#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("forall t." >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t")) + >#< "->" >#< t_st >#< @loc.t_params -- this is a conventional data type, but declared with GADT syntax + ) $ Set.toList @loc.allstates + +-- type of a key which identifies a visit v from state s +SEM ENonterminal + | ENonterminal loc.k_type = "K_" ++ show @nt + loc.k_states = vlist $ map (\st -> + let nt_st = @nt >|< "_s" >|< st + k_st = "K_" >|< nt_st + outg = filter (\(v,f,t) -> f == st) @prods.allvisits + visitlist = vlist $ map (\(v,f,t) -> + @loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params) + ) outg + nextVisit = Map.findWithDefault ManyVis st @nextVisits + decl = "data" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist + in case nextVisit of + NoneVis -> empty + OneVis _ -> empty + ManyVis -> decl + ) $ Set.toList @loc.allstates + +-- type of a visit v, with continuation as new state s +ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ] + +SEM EProductions + | Cons lhs.t_visits = @hd.t_visits -- just pick the first production + +SEM Visit + | Visit loc.nameT_visit = conNmTVisit @lhs.nt @ident + loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident + loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident + loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to + + loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state? + loc.typecon = case @kind of + VisitPure _ -> empty + VisitMonadic -> ppMonadType @lhs.options + + loc.t_params = ppSpaced @lhs.params + lhs.t_visits = "type" >#< @loc.nameT_visit >#< @loc.t_params >#< "=" >#< + pp_parens (@loc.nameTIn_visit >#< @loc.t_params) + >#< ( if dummyTokenVisit @lhs.options + then "->" >#< dummyType @lhs.options True -- Additional (unused though) argument + else empty + ) + >#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params) + >-< "data" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#< + @loc.inhpart + >-< "data" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#< + @loc.synpart >#< case @loc.nextVisitInfo of + NoneVis -> empty -- don't return a continuation at all + _ -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params) -- normal route: select the next semantics + loc.inhpart = @loc.ppTypeList @inh @lhs.inhmap + loc.synpart = @loc.ppTypeList @syn @lhs.synmap + loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of + Just tp -> ppTp tp ) $ Set.toList s + +{ +conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId +conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId +conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId +conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId + +ppMonadType :: Options -> PP_Doc +ppMonadType opts + | parallelInvoke opts = text "IO" + | otherwise = text "Identity" +} + +------------------------------------------------------------------------------- +-- Inh and Syn wrappers +------------------------------------------------------------------------------- +SEM ENonterminal + | ENonterminal loc.wr_inh = @loc.genwrap "Inh" @loc.wr_inhs + loc.wr_syn = @loc.genwrap "Syn" @loc.wr_syns + loc.genwrap = \nm attr -> "data" >#< nm >|< "_" >|< @nt >#< @loc.t_params >#< "=" >#< nm >|< "_" >|< @nt >#< "{" + >#< (ppCommas $ map (\(i,t) -> i >|< "_" >|< nm >|< "_" >|< @nt >#< "::" + >#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)) attr) >#< "}" + loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap + loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.synAttrs + loc.wr_inhs1 = Map.toList @loc.synAttrs + loc.wr_filter = if lateHigherOrderBinding @lhs.options + then Map.delete idLateBindingAttr + else id + loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap + loc.inhlist = map (lhsname @lhs.options True . fst) @loc.wr_inhs + loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1 + loc.synlist = map (lhsname @lhs.options False . fst) @loc.wr_syns + loc.wrapname = "wrap_" ++ show @nt + loc.inhname = "Inh_" ++ show @nt + loc.synname = "Syn_" ++ show @nt + loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits + loc.wrapper = @loc.wrapPragma + >-< (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params >#< "->" + >#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params)) + >-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act")) + >#< (@loc.addbang $ pp_parens (@loc.inhname + >#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "=")) + >-< + indent 3 (case @initialv of + -- case where there are no inherited or synthesized attributes + [] -> @loc.synname >#< " { }" + initvs@(initv:_) -> + let extra = if dummyTokenVisit @lhs.options + then pp $ dummyArg @lhs.options True + else empty + unMonad | monadicWrappers @lhs.options = empty + | otherwise = unMon @lhs.options + genSteps _ [] = [] + genSteps curst (curv:nextvs) = setarg : dovis : genSteps nextst nextvs where + inCon = conNmTVisitIn @nt curv + outCon = conNmTVisitOut @nt curv + pat = @loc.addbang $ pp_parens $ pat0 + pat0 = outCon >#< ppSpaced (map (lhsname @lhs.options False) syns) >#< cont + cont | null nextvs = empty + | otherwise = pp "sem" + inhs = Set.toList $ Map.findWithDefault Set.empty curv @prods.visituses + syns = Set.toList $ Map.findWithDefault Set.empty curv @prods.visitdefs + arg = inCon >#< ppSpaced (map (lhsname @lhs.options True) inhs) + setarg = "let" >#< @loc.addbangWrap (pp "arg" >|< curv) >#< "=" >#< arg + ind = case Map.findWithDefault ManyVis curst @nextVisits of + NoneVis -> error "wrapper: initial state should have a next visit but it has none" + OneVis _ -> empty + ManyVis -> @loc.k_type >|< "_v" >|< initv + nextst = curst + 1 -- This is not correct, but works both for KW and AOAG + -- Should be lookup up based on visit + convert = case Map.lookup curv @lhs.allVisitKinds of + Just kind -> case kind of + VisitPure _ -> text "return" + VisitMonadic -> empty + dovis = pat >#< "<-" >#< convert >#< pp_parens + ("inv_" >|< @nt >|< "_s" >|< curst >#< "sem" >#< ind + >#< "arg" >|< curv >#< extra) + in unMonad >#< "(" + >-< indent 2 ( + "do" >#< ( @loc.addbang (pp "sem") >#< "<-" >#< "act" -- run the per-node monadic code to get the initial state (of the root) + >-< vlist (genSteps @initial initvs) + >-< "return" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist) + ) + ) + >-< ")" ) + >-< if lateHigherOrderBinding @lhs.options + then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName) + else empty + loc.wrapPragma = if parallelInvoke @lhs.options && not (monadicWrappers @lhs.options) + then ppNoInline @loc.wrapname -- required for the use of unsafePerformIO in case of the IO monad + else if noInlinePragmas @lhs.options + then empty + else ppInlinable @loc.wrapname -- ensure that the wrapper is exposed as inlinable + +------------------------------------------------------------------------------- +-- Collection of NT / Production sem funs references +------------------------------------------------------------------------------- + +ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ] +SEM ENonterminal | ENonterminal + lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs + lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps + loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname + loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp + loc.semFunBndNm = lateSemNtLabel @nt + +SEM EProduction | EProduction + lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef + lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp + loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname + loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp + loc.semFunBndNm = lateSemConLabel @lhs.nt @con + +-- Generate a dictionary that contains the semantics of all semantic functions +SEM ExecutionPlan | ExecutionPlan + loc.wrappersExtra = if lateHigherOrderBinding @lhs.options + then @loc.lateSemBndDef + else empty + loc.commonExtra = if lateHigherOrderBinding @lhs.options + then @loc.lateSemBndTp + else empty + loc.lateSemBndTp = "data" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName + >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps) + loc.lateSemBndDef = ( if noInlinePragmas @lhs.options + then empty + else if helpInlining @lhs.options && Set.size @wrappers == 1 + then ppInline $ lateBindingFieldNm @lhs.mainName -- inline in the single wrapper + else ppNoInline $ lateBindingFieldNm @lhs.mainName + ) + >-< lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName + >-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName + >-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs ) + +------------------------------------------------------------------------------- +-- Production semantic functions +------------------------------------------------------------------------------- +ATTR EProduction [ | | sem_prod : {PP_Doc} ] +ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ] + +ATTR EProduction EProductions [ initial : {StateIdentifier} + allstates : {Set StateIdentifier} | | ] +SEM ENonterminal + | ENonterminal prods.initial = @initial + prods.allstates = @loc.allstates + +ATTR EChild [ | | argtps : { PP_Doc } + argpats : { PP_Doc } ] +ATTR EChildren [ | | argtps USE {:} {[]} : { [PP_Doc] } + argpats USE {:} {[]} : { [PP_Doc] } ] + +SEM EChild + | EChild lhs.argtps = case @kind of + ChildSyntax -> ppDefor @tp >#< "->" + ChildReplace tp -> ppDefor tp >#< "->" + _ -> empty -- higher order attribute + loc.argpats = case @kind of + ChildSyntax -> @name >|< "_" -- no strictification of children semantics to allow infinite trees + ChildReplace _ -> @name >|< "_" + _ -> empty + | ETerm lhs.argtps = (pp_parens $ show @tp) >#< "->" + loc.argpats = @loc.addbang $ text $ fieldname @name -- terminals may be strict (perhaps this should become an option) + +{ +ppDefor :: Type -> PP_Doc +ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args) +ppDefor (Haskell s) = text s +} + +SEM EProduction + | EProduction loc.t_type = "T_" >|< @lhs.nt + loc.t_params = ppSpaced @lhs.params + loc.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs + -- A bit ugly, but this code renames arguments and puts an underscore when the argument + -- is never used. This avoids compiler warnings of unused variables. + loc.args = map (\x -> let (name,arg) = case show x of + "" -> ("", empty) + '!':name -> ("arg_" ++ name, "!arg_" >|< name) + name -> ("arg_" ++ name, "arg_" >|< name) + in if null name || name `Set.member` @loc.usedArgs + then arg + else text "_") @children.argpats + loc.semname = "sem_" ++ show @lhs.nt ++ "_" ++ show @con + loc.sem_tp = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps >#< @loc.t_type >#< @loc.t_params + loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints) + loc.quantPP2 = ppQuants (@lhs.params ++ @params) + loc.sem_prod = @loc.semInlinePragma + >-< @loc.semname >#< "::" >#< @loc.sem_tp + >-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.scc >#< @loc.t_type) + @loc.mbInitializer @loc.outerlet ("return" >#< "st" >|< @lhs.initial) + loc.mkSemBody = \prefix mbInit outerlet ret -> + case mbInit of + Nothing -> prefix >#< pp_parens ret >#< "where" + >-< indent 3 outerlet -- code for states and visits + Just m -> prefix >#< "(" >#< "do" + >-< indent 1 ( + m + >-< "let" + >-< indent 2 outerlet -- code for the states and visits + >-< ret ) + >-< indent 1 ")" + + loc.mbInitializer = --some monadic actions, performed upon attaching a child, can + -- be specified here. The resulting bindings of these actions are + -- in scope of the rules of the production + if parallelInvoke @lhs.options + then (Nothing :: Maybe PP_Doc) -- perhaps do some per-node registation, etc. For now: nothing + else Nothing -- nothing special here + loc.scc = if genCostCentres @lhs.options + then ppCostCentre @loc.semname + else empty + loc.semInlinePragma = if noInlinePragmas @lhs.options + then empty + else ppNoInline @loc.semname -- prevent the semantic functions of constructors to be inlined (e.g. in the nt sem-funs) + loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules + loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates + loc.genstfn = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits + prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits + stNm = "st" >|< st + lhs = pragma >-< bang stNm >#< "=" >#< + ( -- generating a lambda for the same reasons as generating + -- a lambda for rules: to ensure that overloading is + -- resolved for all visit functions and rules together. + if st == @lhs.initial + then empty + else "\\" >#< @loc.stargs st >#< "->" + ) + + pragma = if noInlinePragmas @lhs.options + then empty + else if helpInlining @lhs.options + then case prevVisitInfo of + ManyVis -> ppNoInline stNm + OneVis _ -> if aggressiveInlinePragmas @lhs.options + then ppInline stNm + else ppInlinable stNm + NoneVis -> if st /= @lhs.initial + then error ("State " ++ show st ++ " is not reachable from the initial state.") + else if aggressiveInlinePragmas @lhs.options + then ppInline stNm -- first state can be inlined + else ppInlinable stNm + else ppNoInline stNm + cCon = "C_" >|< @lhs.nt >|< "_s" >|< st + bang | st == @lhs.initial = @loc.addbang -- initial state is not parameterized + | otherwise = id + + -- note about the initial state: the initial state should be the only + -- state-binding that is not a function. It is non-recursive and not needed + -- anywhere except delivered as initial result. This binding therefore does + -- not end up needlessly in any closure. + in case nextVisitInfo of + NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced + -- thus generating it is not needed (and omitting it may catch some small mistakes). + if st == @lhs.initial + then lhs >#< cCon -- empty state + else empty -- no state generated + OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId) + ManyVis -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st) + loc.stargs = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap + in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str + | otherwise = @loc.addbang (pp str) + in case mbAttr of + Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> + case Map.lookup nm @loc.localAttrTypes of + Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) + Nothing -> match + Just attr | not (noPerStateTypeSigs @lhs.options) -> + case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of + Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) + Nothing -> match + _ -> match + | (str,mbAttr) <- Map.assocs attrs + ] >#< dummyPat @lhs.options (Map.null attrs) + + loc.stks = \st -> if null (@loc.stvisits st) + then empty + else ( if not (noInlinePragmas @lhs.options) && helpInlining @lhs.options + then ppNoInline ("k" >|< st) + else empty + ) + >-< "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "t" >#< "->" >#< "t" + >-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "=" + >#< "v" >|< v) $ @loc.stvisits st) + loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits + loc.stvs = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st] + visits.mrules = @rules.mrules + +{ +mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc +mklet prefix defs body = + prefix >#< "let" + >-< indent 3 defs + >-< indent 2 "in" >#< body +} + +------------------------------------------------------------------------------- +-- Visit semantic functions +------------------------------------------------------------------------------- +ATTR Visit [ | | sem_visit : { (StateIdentifier,Bool -> PP_Doc) } ] +ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ] + +SEM Visit + | Visit lhs.sem_visit = ( @from + , \addInlinePragma -> + ( if noInlinePragmas @lhs.options + then empty + else if addInlinePragma && aggressiveInlinePragmas @lhs.options + then ppInline @loc.vname + else if helpInlining @lhs.options + then ppNoInline @loc.vname + else empty + ) + >-< "v" >|< @ident >#< "::" >#< @loc.nameT_visit >#< @loc.t_params + + -- generate a lambda here as well instead of a function definition + >-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats)) + >#< ( if dummyTokenVisit @lhs.options + then pp $ dummyPat @lhs.options True -- extra (but unused) argument + else empty + ) + >#< "->" + >#< ( if genCostCentres @lhs.options + then ppCostCentre (@loc.vname >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con) + else empty + ) >#< "(" >#< @loc.stepsInitial + >-< indent 3 (@steps.sem_steps >-< @loc.stepsClosing >#< ")") + ) + loc.stepsInitial = case @kind of + VisitPure False -> text "let" + VisitPure True -> empty + VisitMonadic -> text "do" + loc.stepsClosing = let decls = @loc.nextStBuild + >-< @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval + in case @kind of + VisitPure False -> decls + >-< "in" >#< resultValName + VisitPure True -> "let" >#< decls + >-< indent 1 ("in" >#< resultValName) + VisitMonadic -> "let" >#< decls + >-< "return" >#< resultValName + loc.vname = "v" >|< @ident + loc.inhpats = ppSpaced $ map (\arg -> {-@loc.addbang $-} pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh + loc.inhargs = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh + loc.synargs = ppSpaced $ map (\arg -> attrname @lhs.options False _LHS arg) $ Set.toList @syn + loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap + loc.nextargs = ppSpaced $ Map.keys $ @loc.nextargsMp + loc.nextst = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp) + loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef + (loc.nextStBuild, loc.nextStRef) + = case @loc.nextVisitInfo of + NoneVis -> (empty, empty) + _ -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName) + +{ +resultValName :: String +resultValName = "__result_" + +nextStName :: String +nextStName = "__st_" +} + +-- Propagate the visit kind to the steps +ATTR VisitStep VisitSteps [ kind : VisitKind | | ] +SEM Visit | Visit steps.kind = @kind + +-- the steps in this group should be executed in a pure fashion +SEM VisitStep | PureGroup + steps.kind = VisitPure @ordered + +ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ] +ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ] +SEM VisitStep + | Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules + (lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of + Left e -> (Seq.singleton e, empty) + Right stmt -> (Seq.empty, stmt) + | ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros + (lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses) + = case @loc.attachItf @lhs.kind @lhs.fmtMode of + Left e -> (Seq.singleton e, empty, Set.empty, Map.empty) + Right (code, defs, uses) -> (Seq.empty, code, defs, uses) + | ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit + (lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of + Left e -> (Seq.singleton e, empty, empty) + Right (pat,expr) -> (Seq.empty, pat, expr) + + loc.useParallel = @lhs.useParallel && not @lhs.isLast + lhs.sem_steps = if @loc.useParallel -- assumes to be in a monadic do-expression + then @loc.addbang ("sync_" >|< @lhs.index) >#< "<- newEmptyMVar" + >-< "forkIO" >#< pp_parens (@loc.convToMonad >#< pp_parens @loc.exprPP >#< ">>= \\" >#< @loc.addbang (pp parResultName) >#< " -> putMVar sync_" >|< @lhs.index >#< parResultName) -- parResultName is guaranteed to be evaluated + else let decl = case @lhs.kind of + VisitPure _ -> @loc.patPP >#< "=" >#< @loc.exprPP + VisitMonadic -> @loc.patPP >#< "<-" >#< @loc.exprPP + in fmtDecl False @lhs.fmtMode decl + loc.convToMonad = case @loc.callKind of + VisitPure _ -> text "return" + VisitMonadic -> empty + loc.callKind = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds + | Sim lhs.sem_steps = @steps.sem_steps >-< @steps.sync_steps + | PureGroup lhs.sem_steps = case @lhs.fmtMode of + FormatDo -> "let" >#< @steps.sem_steps -- formatted as a let-block (not a line-let) + _ -> @steps.sem_steps + +ATTR VisitSteps VisitStep [ | | sync_steps USE {>-<} {empty} : {PP_Doc} ] +SEM VisitStep | ChildVisit + lhs.sync_steps = if @loc.useParallel + then @loc.patPP >#< "<-" >#< "takeMVar sync_" >|< @lhs.index + else empty + +-- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing +-- declarations, because that determines how we need to wrap declarations +-- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo +ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ] +SEM Visit | Visit + steps.fmtMode = case @kind of + VisitPure False -> FormatLetDecl + VisitPure True -> FormatLetLine + VisitMonadic -> FormatDo + +SEM VisitStep | PureGroup + steps.fmtMode = case @lhs.fmtMode of + FormatDo -> FormatLetDecl + mode -> mode + +{ +parResultName :: String +parResultName = "__outcome_" + +fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc +fmtDecl declPure fmt decl = case fmt of + FormatLetDecl -> pp decl + FormatLetLine -> "let" >#< decl >#< "in" + FormatDo | declPure -> "let" >#< decl + | otherwise -> pp decl +} + +-- +-- Some properties of VisitStep(s) +-- + +-- Used arguments +ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ] +SEM ERule + | ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs + +SEM EChild + | EChild +usedArgs = \s -> case @kind of + ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s + _ -> s + + +-- Number of steps in a 'Sim' block +ATTR VisitSteps [ | | size : Int ] +SEM VisitSteps + | Nil lhs.size = 0 + | Cons lhs.size = 1 + @tl.size + +-- Number the steps in a 'Sim' block +ATTR VisitSteps VisitStep [ | index : Int | ] +SEM VisitSteps | Cons + hd.index = @lhs.index -- copy rule + tl.index = 1 + @lhs.index + lhs.index = @tl.index -- copy rule +SEM Visit | Visit steps.index = 0 +SEM VisitStep | Sim steps.index = 0 + lhs.index = @lhs.index -- needed for if we ever allow nested Sims + +-- Biggest number of steps in previous blocks that used parallel invocation +-- This number - 1 (minimum 0) is the number of references for parallel invocation created +ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ] +SEM Visit | Visit steps.prevMaxSimRefs = 0 +SEM VisitStep | Sim + lhs.prevMaxSimRefs = if @loc.useParallel + then @lhs.prevMaxSimRefs `max` (@steps.index - 1) -- possibly new references made + else @lhs.prevMaxSimRefs -- no references created + +-- Is this the last step? +ATTR VisitSteps VisitStep [ | | isLast : Bool ] +ATTR VisitStep [ isLast : Bool | | ] +SEM VisitSteps + | Nil lhs.isLast = True + | Cons lhs.isLast = False + hd.isLast = @tl.isLast + +-- Use parallel invocation: only when option enabled and there is more than one visit to a child +SEM VisitSteps VisitStep [ useParallel : Bool | | ] +SEM Visit | Visit steps.useParallel = False +SEM VisitStep | Sim loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1 && @loc.isMonadic + loc.isMonadic = case @lhs.kind of + VisitMonadic -> True + _ -> False + + +-- Child introduction +ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ] + +ATTR Visits Visit + VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ] + +SEM EProduction + | EProduction visits.childintros = @children.childintros + +SEM EChild + | ETerm lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty)) + | EChild lhs.childintros = Map.singleton @name @loc.introcode + loc.isDefor = case @tp of + NT _ _ defor -> defor + _ -> False + loc.valcode = case @kind of + ChildSyntax -> "arg_" >|< @name >|< "_" + ChildAttr -> -- decide if we need to invoke the sem-function under the hood + let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options -- when sepsemmods is not enabled, the indirection can be optimized away + then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr + else "sem_" >|< @loc.nt + | otherwise = empty -- no need to intro a terminal + in pp_parens (prefix >#< instname @name) + ChildReplace _ -> -- the higher-order attribute is actually a function that transforms + -- the semantics of the child (always deforested) + pp_parens (instname @name >#< @name >|< "_") + loc.aroundcode = if @hasAround + then locname @lhs.options @name >|< "_around" + else empty + loc.introcode = \kind fmtMode -> + let pat = text $ stname @name @loc.initSt + patStrict = @loc.addbang pat + attach = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode) + runAttach = unMon @lhs.options >#< pp_parens attach + decl = case kind of + VisitPure False -> pat >#< "=" >#< runAttach + VisitPure True -> patStrict >#< "=" >#< runAttach + VisitMonadic -> patStrict >#< "<-" >#< attach + in if compatibleAttach kind @loc.nt @lhs.options + then Right ( fmtDecl False fmtMode decl + , Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro + , case @kind of -- variables used by the child introduction + ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr + ( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options) + then id -- the sem dictionary attr is not used + else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr) + ) $ + ( if @hasAround + then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing + else id + ) $ Map.empty + ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function + ChildSyntax -> Map.empty + ) + else Left $ IncompatibleAttachKind @name kind + loc.nt = extractNonterminal @tp + +{ +stname :: Identifier -> Int -> String +stname child st = "_" ++ getName child ++ "X" ++ show st + +-- should actually return some conversion info +compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool +compatibleAttach _ _ _ = True + +unMon :: Options -> PP_Doc +unMon options + | parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO" -- IO monad + | otherwise = text "Control.Monad.Identity.runIdentity" -- identity monad +} + +-- rules +ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc} + mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ] + +SEM ERule | ERule + lhs.sem_rules = if @loc.used == 0 + then empty + else @loc.rulePragma >-< @loc.rulecode + loc.rulecode = ( if @loc.genpragma + then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of + -- type errors in the rule. It will definitely not be precise, and may take some additional + -- source space, but let's see if it's worth it in practice. + else empty + ) + >-< @loc.lambda >#< @loc.scc + >-< indent ((column @rhs.pos - 2) `max` 2) + ( if @loc.genpragma + then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma + else @rhs.semfunc + ) + loc.rulePragma = ( let reallyInlineStr = "INLINE" + reallyNoInlineStr = "NOINLINE" + in if noInlinePragmas @lhs.options + then empty + else if @loc.used == 1 + then ppPragmaBinding reallyInlineStr @name -- always inline if used exactly once + else if helpInlining @lhs.options + then if not @explicit && @loc.used <= reallyOftenUsedThreshold + then ppPragmaBinding "INLINE[1]" @name -- inline if copy rule + else if @loc.used > ruleInlineThresholdSoft && @explicit -- noinline if it passes the threshold and is not a copy rule + then if @loc.used > ruleInlineThresholdHard + then ppPragmaBinding reallyNoInlineStr @name -- used too often: force ghc not to inline it + else if aggressiveInlinePragmas @lhs.options + then ppPragmaBinding "NOINLINE[2]" @name -- allow inlining but only late in the process + else ppNoInline @name + else if aggressiveInlinePragmas @lhs.options + then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first) + else ppNoInline @name + else if not @explicit || @loc.used <= ruleInlineThresholdSoft + then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first) + else ppNoInline @name + ) + loc.scc = if genCostCentres @lhs.options && @explicit && @pure && not (noPerRuleCostCentres @lhs.options) + then ppCostCentre (@name >|< "_" >|< line @rhs.pos >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con) + else empty + loc.pragma = "{-# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#-}" + loc.endpragma = ppWithLineNr (\ln -> "{-# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#-}") + loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos + loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos)) + + -- we generate a simple pattern binding because of overloading-resolving during the type inference process. + -- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context). + -- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have + -- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead + -- of a function definition. + -- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures + -- but are lambda-lifted instead. + loc.lambda = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->" + + loc.argPats = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str + | otherwise = @loc.addbang1 (pp str) + in case mbAttr of + Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) -> + case Map.lookup nm @lhs.localAttrTypes of + Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp) + Nothing -> match + Just attr | not (noPerRuleTypeSigs @lhs.options) -> + case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of + Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc) + Nothing -> match + _ -> match + | (str,mbAttr) <- Map.assocs @rhs.attrs + ] + loc.argExprs = ppSpaced [ case mbAttr of + Nothing -> "arg_" >|< str + _ -> text str + | (str,mbAttr) <- Map.assocs @rhs.attrs + ] + loc.stepcode = \kind fmtMode -> if kind `compatibleRule` @pure + then Right $ let oper | @pure = "=" + | otherwise = "<-" + decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs) + tp = if @pure && not (noPerRuleTypeSigs @lhs.options) + then @pattern.attrTypes + else empty + in fmtDecl @pure fmtMode (tp >-< decl) + else Left $ IncompatibleRuleKind @name kind + + lhs.mrules = Map.singleton @name @loc.stepcode + +ATTR Expression [ | | tks : {[HsToken]} ] +SEM Expression + | Expression lhs.tks = @tks + +{ +dummyPat :: Options -> Bool -> PP_Doc +dummyPat opts noArgs + | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples + | tupleAsDummyToken opts = if strictDummyToken opts + then text "()" + else text "(_ :: ())" + | otherwise = let match | strictDummyToken opts = "!_" + | otherwise = "_" + in pp_parens (match >#< "::" >#< dummyType opts noArgs) + where match | strictDummyToken opts = "(!_)" + | otherwise = "_" + +dummyArg :: Options -> Bool -> PP_Doc +dummyArg opts noArgs + | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples + | tupleAsDummyToken opts = text "()" + | otherwise = text "GHC.Prim.realWorld#" + +dummyType :: Options -> Bool -> PP_Doc +dummyType opts noArgs + | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples + | tupleAsDummyToken opts = text "()" + | otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)" +} + +{ +-- rules are "deinlined" to prevent needless code duplication. +-- if there is only a bit of duplication, we allow ghc to decide if it is worth it. +-- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it. +ruleInlineThresholdSoft :: Int +ruleInlineThresholdSoft = 3 + +ruleInlineThresholdHard :: Int +ruleInlineThresholdHard = 5 + +reallyOftenUsedThreshold :: Int +reallyOftenUsedThreshold = 12 +} + +ATTR Expression [ | | pos : {Pos} ] +SEM Expression | Expression lhs.pos = @pos + +-- pattern and expression semantics +ATTR Pattern [ | | sem_lhs : { PP_Doc } ] +ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ] +ATTR Pattern Patterns [ | | ] + +SEM Pattern + | Alias loc.varPat = text $ attrname @lhs.options False @field @attr + loc.patExpr = if @pat.isUnderscore + then @loc.varPat + else @loc.varPat >|< "@" >|< @pat.sem_lhs + lhs.sem_lhs = @loc.addbang1 @loc.patExpr + | Product lhs.sem_lhs = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs + | Constr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs + | Underscore lhs.sem_lhs = text "_" + | Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs + +-- Check if a pattern is just an underscore +ATTR Pattern [ | | isUnderscore:{Bool}] +SEM Pattern + | Constr lhs.isUnderscore = False + | Product lhs.isUnderscore = False + | Alias lhs.isUnderscore = False + | Underscore lhs.isUnderscore = True + +-- Collect the attributes defined by a pattern +ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ] +SEM Pattern | Alias + lhs.attrs = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs + +-- All attribute types of this pattern +ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ] +SEM Pattern | Alias + loc.mbTp = if @field == _LHS + then Map.lookup @attr @lhs.synmap + else if @field == _LOC + then Map.lookup @attr @lhs.localAttrTypes + else Nothing + lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp + >-< @pat.attrTypes + +-- Collect the attributes used by the right-hand side +ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] +SEM HsToken + | AGLocal lhs.attrs = Map.singleton (fieldname @var) Nothing + | AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST' + then Nothing -- should not be used in the first place + else Just $ mkNonLocalAttr (@field == _LHS) @field @attr + lhs.attrs = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr + +{ +data NonLocalAttr + = AttrInh Identifier Identifier + | AttrSyn Identifier Identifier deriving Show + +mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr +mkNonLocalAttr True = AttrInh -- True: inherited attr +mkNonLocalAttr False = AttrSyn + +lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc +lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs +lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns + +-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that +-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. +-- However, for now we simply decide to return Nothing in this case, which skips the type annotation. +lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc +lookupType child name attrMp childMp + | noParameters childTp = Just ppDoc + | otherwise = Nothing + where + attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs + childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp + nonterm = extractNonterminal childTp + childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp + ppDoc = ppTp attrTp + +noParameters :: Type -> Bool +noParameters (Haskell _) = True +noParameters (NT _ args _) = null args +} + +ATTR Expression [ | | semfunc : {PP_Doc} ] + +SEM Expression + | Expression lhs.attrs = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks + lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks + loc.inhhstoken = Inh_HsToken @lhs.options + +-- child visit map +ATTR Visit + Visits + EProduction + EProductions + ENonterminal + ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} + | | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ] + +ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ] + +SEM ExecutionPlan + | ExecutionPlan nonts.allchildvisit = @nonts.childvisit + +SEM Visit + | Visit + loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits + lhs.childvisit = Map.singleton @ident @loc.invokecode + loc.invokecode = \chn kind -> -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit + if kind `compatibleKind` @kind + then Right $ + let pat | isLazyKind @kind = pat0 + | otherwise = @loc.addbang pat0 + pat0 = pp_parens pat1 + pat1 = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname @lhs.options True chn) $ Set.toList @syn) + >#< cont + cont = case @loc.nextVisitInfo of + NoneVis -> empty + _ -> ch1 + ch0 = text $ stname chn @from + ch1 = text $ stname chn @to + expr = case (kind, @kind) of + (VisitPure _, VisitPure _) -> expr0 + (VisitPure _, VisitMonadic) -> unMon @lhs.options >#< expr0 + (VisitMonadic, VisitPure _) -> "return" >#< expr0 + (VisitMonadic, VisitMonadic) -> expr0 + expr0 = case @loc.prevVisitInfo of + NoneVis -> error "error: invocation of a visit from a state that has no next visits" + OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args + ManyVis -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 + >#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args + args = pp_parens args0 >#< args1 + args0 = @loc.nameTIn_visit >#< @loc.inhargs chn + args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True + | otherwise = empty + in (pat, expr) -- pretty print of the pattern and the expression part + else Left $ IncompatibleVisitKind chn @ident kind @kind + +{ +-- a `compatibleKind` b means: can kind b be invoked from a +compatibleKind :: VisitKind -> VisitKind -> Bool +compatibleKind _ _ = True + +compatibleRule :: VisitKind -> Bool -> Bool +compatibleRule (VisitPure _) False = False +compatibleRule _ _ = True +} + +------------------------------------------------------------------------------- +-- Properties of rules +------------------------------------------------------------------------------- + +-- Construct an environment that counts how often certain rules are used +ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ] +ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ] + +SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage +SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1 +SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo + +{ +unionWithSum = Map.unionWith (+) +} + +-- Collect in what visit-kinds a rule is used +ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ] +SEM VisitStep | Sem + lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind) + +ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ] +SEM EProduction | EProduction + rules.ruleKinds = @visits.ruleKinds + +SEM ERule | ERule + loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds + loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds + +ATTR Pattern Patterns [ anyLazyKind : Bool | | ] + + +------------------------------------------------------------------------------- +-- Intra attributes +------------------------------------------------------------------------------- +{ +uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) +uwSetUnion = Map.unionWith Set.union + +uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) +uwMapUnion = Map.unionWith Map.union +} +ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} + | | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ] + +ATTR Visit Visits [ terminaldefs : {Set String} | | ] +ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ] + +SEM EChild | ETerm + lhs.terminaldefs = Set.singleton $ fieldname @name + +SEM EProduction | EProduction + visits.allintramap = @visits.intramap + visits.terminaldefs = @children.terminaldefs + +SEM Visit + | Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap + lhs.intramap = Map.singleton @from @loc.thisintra + loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap + loc.uses = let mp1 = @steps.uses + mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ] + in mp1 `Map.union` mp2 + loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh + loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs + loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ] + +ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)} + ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ] +ATTR Visit Visits + VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)} + ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ] + +SEM ERule + | ERule lhs.ruledefs = Map.singleton @name @pattern.attrs + lhs.ruleuses = Map.singleton @name @rhs.attrs + +SEM EProduction + | EProduction visits.ruledefs = @rules.ruledefs + visits.ruleuses = @rules.ruleuses + +ATTR Visit Visits + EProduction + EProductions + ENonterminal + ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} + visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ] + +SEM Visit + | Visit lhs.visitdefs = Map.singleton @ident @syn + lhs.visituses = Map.singleton @ident @inh + +ATTR Visit Visits + VisitSteps VisitStep + EProduction EProductions + ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)} + avisituses : {Map VisitIdentifier (Set Identifier)} | | ] + +SEM ExecutionPlan + | ExecutionPlan nonts.avisitdefs = @nonts.visitdefs + nonts.avisituses = @nonts.visituses + +ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String} + uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] +SEM VisitStep + | Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs + lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses + | ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs + lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ] + in Map.insert (stname @child @from) Nothing $ convert $ + maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses + +------------------------------------------------------------------------------- +-- Identification of lazy intra defs within a production +-- +-- These identifiers will not be marked as strict in rules and state closures +------------------------------------------------------------------------------- + +ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ] +ATTR ERules ERule [ lazyIntras : {Set String} | | ] + +SEM Visit | Visit + loc.lazyIntrasInh = case @kind of + VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs + _ -> Set.empty + lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras + +SEM VisitStep | PureGroup + lhs.lazyIntras = if @ordered + then @steps.lazyIntras + else @steps.defs + +SEM EProduction | EProduction + loc.lazyIntras = @visits.lazyIntras + +------------------------------------------------------------------------------- +-- Pretty printing of haskell code +------------------------------------------------------------------------------- + +SEM HsTokens [ || tks : {[(Pos,String)]} ] + | Cons lhs.tks = @hd.tok : @tl.tks + | Nil lhs.tks = [] + +SEM HsToken + | AGLocal loc.tok = (@pos,fieldname @var) + +SEM HsToken [ || tok:{(Pos,String)}] + | AGField + loc.addTrace = case @rdesc of + Just d -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))" + Nothing -> id + lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr) + + | HsToken lhs.tok = (@pos, @value) + + | CharToken lhs.tok = (@pos, if null @value + then "" + else showCharShort (head @value) + ) + + | StrToken lhs.tok = (@pos, showStrShort @value) + | Err lhs.tok = (@pos, "") + +------------------------------------------------------------------------------- +-- Alternative code generation (sepsemmods) +------------------------------------------------------------------------------- + +ATTR ExecutionPlan [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc} + | | genIO : {IO ()} ] + +SEM ExecutionPlan + | ExecutionPlan lhs.genIO = do @loc.genMainModule + @loc.genCommonModule + @nonts.genProdIO + loc.mainModuleFile = @lhs.mainFile + loc.ppMonadImports = ( if tupleAsDummyToken @lhs.options + then empty + else pp "import GHC.Prim" + ) + >-< if parallelInvoke @lhs.options + then pp "import qualified System.IO.Unsafe(unsafePerformIO)" + >-< pp "import System.IO(IO)" + >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)" + else pp "import Control.Monad.Identity" + loc.genMainModule = writeModule @loc.mainModuleFile + ( [ warrenFlagsPP @lhs.options + , pp $ @lhs.pragmaBlocks + , pp $ @lhs.moduleHeader @lhs.mainName "" "" False + , @loc.ppMonadImports + , pp $ "import " ++ @lhs.mainName ++ "_common" + ] + ++ @nonts.imports + ++ [@lhs.mainBlocksDoc] + ++ [@loc.wrappersExtra] + ++ @nonts.appendMain + ) + loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") + loc.genCommonModule = writeModule @loc.commonFile + ( [ pp $ "{-# LANGUAGE Rank2Types, GADTs #-}" -- the common module only needs GADTs and Rank2Types + , pp $ @lhs.pragmaBlocks + , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True + , @loc.ppMonadImports + , @lhs.importBlocks + , @lhs.textBlocks + , @loc.commonExtra + ] + ++ @nonts.appendCommon + ) + +ATTR ENonterminal [ | | appendCommon, appendMain : { PP_Doc } ] +ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ] + +SEM ENonterminal + | ENonterminal lhs.appendMain = (if @nt `Set.member` @lhs.wrappers + then @loc.wr_inh + >-< @loc.wr_syn + >-< @loc.wrapper + else empty) + >-< @loc.sem_nt + lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty) + >-< @loc.t_init + >-< @loc.t_states + >-< @loc.k_states + >-< @prods.t_visits + +ATTR EProduction EProductions + ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]} + genProdIO USE {>>} {return ()} : {IO ()} ] + +SEM EProduction + | EProduction lhs.imports = [pp $ "import " ++ @loc.moduleName] + loc.moduleName = @lhs.mainName ++ @loc.suffix + loc.suffix = "_" ++ show @lhs.nt ++ "_" ++ show @con + loc.outputfile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix) + loc.ppMonadImports = if parallelInvoke @lhs.options + then pp "import qualified System.IO.Unsafe(unsafePerformIO)" + >-< pp "import System.IO(IO)" + >-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)" + else pp "import Control.Monad.Identity" + lhs.genProdIO = writeModule @loc.outputfile + [ warrenFlagsPP @lhs.options + , pp $ @lhs.pragmaBlocks + , pp $ @lhs.moduleHeader @lhs.mainName @loc.suffix @loc.semname True + , @lhs.importBlocks + , @loc.ppMonadImports + , ( if tupleAsDummyToken @lhs.options + then empty + else pp "import GHC.Prim" -- need it to pass State# + ) + , pp $ "import " ++ @lhs.mainName ++ "_common" + , @loc.sem_prod + ] + +{ +renderDocs :: [PP_Doc] -> String +renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" + +writeModule :: FilePath -> [PP_Doc] -> IO () +writeModule path docs + = do bExists <- doesFileExist path + if bExists + then do input <- readFile path + seq (length input) (return ()) + if input /= output + then dumpIt + else return () + else dumpIt + where + output = renderDocs docs + dumpIt = writeFile path output +} + + +-- +-- Bang pattern usage +-- + +SEM ERule | ERule loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM Visit | Visit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM ENonterminal | ENonterminal loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM EProduction | EProduction loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM EChild | EChild loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM EChild | ETerm loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM VisitStep | ChildVisit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM Pattern | Alias Constr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x + +SEM Visit | Visit loc.addbang1 = if isLazyKind @kind then id else @loc.addbang +SEM ENonterminal | ENonterminal loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id +SEM ERule | ERule loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang +SEM Pattern | Alias Constr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang + +-- +-- Distribute single-visit-next map downward +-- + +ATTR EProductions EProduction Visits Visit + [ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ] + +SEM ENonterminal | ENonterminal + prods.nextVisits = @nextVisits + prods.prevVisits = @prevVisits + +-- +-- Collect and distribute the from/to states of a visit +-- + +ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit + [ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ] + +ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep + [ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ] + +SEM Visit | Visit + lhs.fromToStates = Map.singleton @ident (@from, @to) + +SEM ExecutionPlan | ExecutionPlan + nonts.allFromToStates = @nonts.fromToStates + +SEM VisitStep | ChildVisit + (loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates + + +-- +-- Collect and distribute the actual types of children of productions +-- + +ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ] +ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ] + +SEM EProduction | EProduction + loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes + +SEM EChild | EChild ETerm + lhs.childTypes = Map.singleton @name @tp + +-- +-- Distribute types of local attributes +-- + +ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ] +ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ] +ATTR ERules ERule Pattern Patterns [ localAttrTypes : {Map Identifier Type} | | ] + +SEM ENonterminal | ENonterminal + prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes + +SEM EProduction | EProduction + loc.localAttrTypes = Map.findWithDefault Map.empty @con @lhs.localAttrTypes + +-- +-- Collect and distribute visit kinds +-- + +ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep + [ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ] + +SEM Visit | Visit + lhs.visitKinds = Map.singleton @ident @kind + +SEM ExecutionPlan | ExecutionPlan + nonts.allVisitKinds = @nonts.visitKinds + +-- +-- Collect and distribute the initial state of nonterminals +-- + +ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ] +ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep + [ allInitStates : {Map NontermIdent Int} | | ] + +SEM ENonterminal | ENonterminal + lhs.initStates = Map.singleton @nt @initial + +SEM ExecutionPlan | ExecutionPlan + nonts.allInitStates = @nonts.initStates + +SEM EChild | EChild + loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates + +-- +-- Push the nonterminal type downward +-- + +ATTR EProductions EProduction [ ntType : Type | | ] +SEM ENonterminal | ENonterminal + loc.ntType = NT @nt (map show @params) False + +-- +-- Collect errors contained in rules that should be yielded when the +-- rules are scheduled. +-- + +ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] +SEM ERule | ERule + lhs.errors = case @mbError of + Just e | @loc.used > 0 -> Seq.singleton e + _ -> Seq.empty + + +-- Some pretty printing utility functions +{ +ppNoInline :: PP a => a -> PP_Doc +ppNoInline = ppPragmaBinding "NOINLINE" + +ppInline :: PP a => a -> PP_Doc +ppInline = ppPragmaBinding "INLINE" + +ppInlinable :: PP a => a -> PP_Doc +ppInlinable = ppPragmaBinding "INLINABLE" + +ppPragmaBinding :: (PP a, PP b) => a -> b -> PP_Doc +ppPragmaBinding pragma nm = "{-#" >#< pragma >#< nm >#< "#-}" + +ppCostCentre :: PP a => a -> PP_Doc +ppCostCentre nm = "{-#" >#< "SCC" >#< "\"" >|< nm >|< "\"" >#< "#-}" + +warrenFlagsPP :: Options -> PP_Doc +warrenFlagsPP options = vlist + [ pp "{-# LANGUAGE Rank2Types, GADTs #-}" + , if bangpats options + then pp "{-# LANGUAGE BangPatterns #-}" + else empty + , if noPerRuleTypeSigs options && noPerStateTypeSigs options + then empty + else pp "{-# LANGUAGE ScopedTypeVariables #-}" + , if tupleAsDummyToken options + then empty + else pp "{-# LANGUAGE ScopedTypeVariables, MagicHash #-}" + , -- not that the meaning of "unbox" is here that strict fields in data types may be + -- unboxed if possible. This may affect user-defined data types declared in the module. + -- Unfortunately, we cannot turn it on for only the AG generated data types without + -- causing a zillion of warnings. + if unbox options && bangpats options + then pp $ "{-# OPTIONS_GHC -funbox-strict-fields -fstrictness #-}" + else empty + , if parallelInvoke options && not (noEagerBlackholing options) + then pp $ "{-# OPTIONS_GHC -feager-blackholing #-}" + else empty + ] +} diff --git a/src-ag/ExecutionPlanCommon.ag b/src-ag/ExecutionPlanCommon.ag --- a/src-ag/ExecutionPlanCommon.ag +++ b/src-ag/ExecutionPlanCommon.ag @@ -1,161 +1,161 @@ -------------------------------------------------------------------------------- --- Distributing options -------------------------------------------------------------------------------- -ATTR Grammar Nonterminals Nonterminal Productions Production Children Child - [ options : {Options} | | ] - -------------------------------------------------------------------------------- --- Find out which nonterminals are recursive -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal [ | | ntDeps, ntHoDeps USE {`mappend`} {mempty} : {Map NontermIdent (Set NontermIdent)} ] -ATTR Nonterminals Nonterminal [ closedNtDeps, closedHoNtDeps, closedHoNtRevDeps : {Map NontermIdent (Set NontermIdent)} | | ] -ATTR Productions Production Children Child [ | | refNts, refHoNts USE {`mappend`} {mempty} : {Set NontermIdent} ] - -SEM Nonterminal | Nonterminal - lhs.ntDeps = Map.singleton @nt @prods.refNts - lhs.ntHoDeps = Map.singleton @nt @prods.refHoNts - - loc.closedNtDeps = Map.findWithDefault Set.empty @nt @lhs.closedNtDeps - loc.closedHoNtDeps = Map.findWithDefault Set.empty @nt @lhs.closedHoNtDeps - loc.closedHoNtRevDeps = Map.findWithDefault Set.empty @nt @lhs.closedHoNtRevDeps - - loc.recursive = @nt `Set.member` @loc.closedNtDeps - loc.nontrivAcyc = @nt `Set.member` @loc.closedHoNtDeps - loc.hoInfo = HigherOrderInfo { hoNtDeps = @loc.closedHoNtDeps - , hoNtRevDeps = @loc.closedHoNtRevDeps - , hoAcyclic = @loc.nontrivAcyc - } - -SEM Child | Child - loc.refNts = case @tp of - NT nt _ _ -> Set.singleton nt - _ -> mempty - loc.refHoNts = if @loc.isHigherOrder then @loc.refNts else mempty - loc.isHigherOrder = case @kind of - ChildSyntax -> False - _ -> True - -SEM Grammar | Grammar - loc.closedNtDeps = closeMap @nonts.ntDeps - loc.closedHoNtDeps = closeMap @nonts.ntHoDeps - loc.closedHoNtRevDeps = revDeps @loc.closedHoNtDeps - -------------------------------------------------------------------------------- --- Distribute the ContextMap to nonterminals -------------------------------------------------------------------------------- - -ATTR Nonterminals Nonterminal [ classContexts : ContextMap | | ] - -SEM Grammar | Grammar - nonts.classContexts = @contextMap - -SEM Nonterminal | Nonterminal - loc.classContexts = Map.findWithDefault [] @nt @lhs.classContexts - -------------------------------------------------------------------------------- --- Gather all rules per production for the execution plan -------------------------------------------------------------------------------- -ATTR Expression [ | | copy : SELF ] - -ATTR Rule [ | | erules : ERule ] -ATTR Rules [ | | erules USE {:} {[]} : ERules ] - -SEM Rule - | Rule lhs.erules = ERule @loc.rulename - @pattern.copy - @rhs.copy - @owrt - @origin - @explicit - @pure - @mbError - -------------------------------------------------------------------------------- --- Determine which children have an around-rule -------------------------------------------------------------------------------- - --- Propagate the around-map downward -ATTR Nonterminals Nonterminal - [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ] - -ATTR Productions Production - [ aroundMap : {Map ConstructorIdent (Map Identifier [Expression])} || ] - -ATTR Children Child - [ aroundMap : {Map Identifier [Expression]} | | ] - -SEM Nonterminal | Nonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap -SEM Production | Production loc.aroundMap = Map.findWithDefault Map.empty @con @lhs.aroundMap - -SEM Grammar | Grammar - nonts.aroundMap = @aroundsMap - -SEM Child | Child - loc.hasArounds = case Map.lookup @name @lhs.aroundMap of - Nothing -> False - Just as -> not (null as) - -------------------------------------------------------------------------------- --- Determine which children are used by merges -------------------------------------------------------------------------------- - --- Propagate the around-map downward -ATTR Nonterminals Nonterminal - [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))} || ] - -ATTR Productions Production - [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))} || ] - -ATTR Children Child - [ mergeMap : {Map Identifier (Identifier, [Identifier], Expression)} mergedChildren : {Set Identifier} | | ] - -SEM Nonterminal | Nonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap -SEM Production | Production loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap - -SEM Grammar | Grammar - nonts.mergeMap = @mergeMap - -SEM Production | Production - loc.mergedChildren = Set.unions [ Set.fromList ms | (_,ms,_) <- Map.elems @loc.mergeMap ] - -SEM Child | Child - loc.merges = maybe Nothing (\(_,ms,_) -> Just ms) $ Map.lookup @name @lhs.mergeMap - loc.isMerged = @name `Set.member` @lhs.mergedChildren - - -------------------------------------------------------------------------------- --- Gather all childs per production for the execution plan -------------------------------------------------------------------------------- - -ATTR Child [ | | echilds : EChild ] -ATTR Children [ | | echilds USE {:} {[]} : EChildren ] - -SEM Child - | Child lhs.echilds = case @tp of - NT _ _ _ -> EChild @name @tp @kind @loc.hasArounds @loc.merges @loc.isMerged - _ -> ETerm @name @tp - -------------------------------------------------------------------------------- --- Output nonterminal type mappings -------------------------------------------------------------------------------- -ATTR Grammar - Nonterminals [ | | inhmap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent Attributes} - synmap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent Attributes} ] - -ATTR Nonterminal [ | | inhmap : {Map.Map NontermIdent Attributes} - synmap : {Map.Map NontermIdent Attributes} ] -SEM Nonterminal - | Nonterminal lhs.inhmap = Map.singleton @nt @inh - lhs.synmap = Map.singleton @nt @syn - -------------------------------------------------------------------------------- --- Output nonterminal type mappings -------------------------------------------------------------------------------- -ATTR Grammar Nonterminals Nonterminal [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))} ] -ATTR Productions Production [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map ConstructorIdent (Map.Map Identifier Type)} ] -ATTR TypeSigs TypeSig [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map Identifier Type} ] - -SEM Nonterminal | Nonterminal lhs.localSigMap = Map.singleton @nt @prods.localSigMap -SEM Production | Production lhs.localSigMap = Map.singleton @con @typeSigs.localSigMap -SEM TypeSig | TypeSig lhs.localSigMap = Map.singleton @name @tp +------------------------------------------------------------------------------- +-- Distributing options +------------------------------------------------------------------------------- +ATTR Grammar Nonterminals Nonterminal Productions Production Children Child + [ options : {Options} | | ] + +------------------------------------------------------------------------------- +-- Find out which nonterminals are recursive +------------------------------------------------------------------------------- + +ATTR Nonterminals Nonterminal [ | | ntDeps, ntHoDeps USE {`mappend`} {mempty} : {Map NontermIdent (Set NontermIdent)} ] +ATTR Nonterminals Nonterminal [ closedNtDeps, closedHoNtDeps, closedHoNtRevDeps : {Map NontermIdent (Set NontermIdent)} | | ] +ATTR Productions Production Children Child [ | | refNts, refHoNts USE {`mappend`} {mempty} : {Set NontermIdent} ] + +SEM Nonterminal | Nonterminal + lhs.ntDeps = Map.singleton @nt @prods.refNts + lhs.ntHoDeps = Map.singleton @nt @prods.refHoNts + + loc.closedNtDeps = Map.findWithDefault Set.empty @nt @lhs.closedNtDeps + loc.closedHoNtDeps = Map.findWithDefault Set.empty @nt @lhs.closedHoNtDeps + loc.closedHoNtRevDeps = Map.findWithDefault Set.empty @nt @lhs.closedHoNtRevDeps + + loc.recursive = @nt `Set.member` @loc.closedNtDeps + loc.nontrivAcyc = @nt `Set.member` @loc.closedHoNtDeps + loc.hoInfo = HigherOrderInfo { hoNtDeps = @loc.closedHoNtDeps + , hoNtRevDeps = @loc.closedHoNtRevDeps + , hoAcyclic = @loc.nontrivAcyc + } + +SEM Child | Child + loc.refNts = case @tp of + NT nt _ _ -> Set.singleton nt + _ -> mempty + loc.refHoNts = if @loc.isHigherOrder then @loc.refNts else mempty + loc.isHigherOrder = case @kind of + ChildSyntax -> False + _ -> True + +SEM Grammar | Grammar + loc.closedNtDeps = closeMap @nonts.ntDeps + loc.closedHoNtDeps = closeMap @nonts.ntHoDeps + loc.closedHoNtRevDeps = revDeps @loc.closedHoNtDeps + +------------------------------------------------------------------------------- +-- Distribute the ContextMap to nonterminals +------------------------------------------------------------------------------- + +ATTR Nonterminals Nonterminal [ classContexts : ContextMap | | ] + +SEM Grammar | Grammar + nonts.classContexts = @contextMap + +SEM Nonterminal | Nonterminal + loc.classContexts = Map.findWithDefault [] @nt @lhs.classContexts + +------------------------------------------------------------------------------- +-- Gather all rules per production for the execution plan +------------------------------------------------------------------------------- +ATTR Expression [ | | copy : SELF ] + +ATTR Rule [ | | erules : ERule ] +ATTR Rules [ | | erules USE {:} {[]} : ERules ] + +SEM Rule + | Rule lhs.erules = ERule @loc.rulename + @pattern.copy + @rhs.copy + @owrt + @origin + @explicit + @pure + @mbError + +------------------------------------------------------------------------------- +-- Determine which children have an around-rule +------------------------------------------------------------------------------- + +-- Propagate the around-map downward +ATTR Nonterminals Nonterminal + [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ] + +ATTR Productions Production + [ aroundMap : {Map ConstructorIdent (Map Identifier [Expression])} || ] + +ATTR Children Child + [ aroundMap : {Map Identifier [Expression]} | | ] + +SEM Nonterminal | Nonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap +SEM Production | Production loc.aroundMap = Map.findWithDefault Map.empty @con @lhs.aroundMap + +SEM Grammar | Grammar + nonts.aroundMap = @aroundsMap + +SEM Child | Child + loc.hasArounds = case Map.lookup @name @lhs.aroundMap of + Nothing -> False + Just as -> not (null as) + +------------------------------------------------------------------------------- +-- Determine which children are used by merges +------------------------------------------------------------------------------- + +-- Propagate the around-map downward +ATTR Nonterminals Nonterminal + [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))} || ] + +ATTR Productions Production + [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))} || ] + +ATTR Children Child + [ mergeMap : {Map Identifier (Identifier, [Identifier], Expression)} mergedChildren : {Set Identifier} | | ] + +SEM Nonterminal | Nonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap +SEM Production | Production loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap + +SEM Grammar | Grammar + nonts.mergeMap = @mergeMap + +SEM Production | Production + loc.mergedChildren = Set.unions [ Set.fromList ms | (_,ms,_) <- Map.elems @loc.mergeMap ] + +SEM Child | Child + loc.merges = maybe Nothing (\(_,ms,_) -> Just ms) $ Map.lookup @name @lhs.mergeMap + loc.isMerged = @name `Set.member` @lhs.mergedChildren + + +------------------------------------------------------------------------------- +-- Gather all childs per production for the execution plan +------------------------------------------------------------------------------- + +ATTR Child [ | | echilds : EChild ] +ATTR Children [ | | echilds USE {:} {[]} : EChildren ] + +SEM Child + | Child lhs.echilds = case @tp of + NT _ _ _ -> EChild @name @tp @kind @loc.hasArounds @loc.merges @loc.isMerged + _ -> ETerm @name @tp + +------------------------------------------------------------------------------- +-- Output nonterminal type mappings +------------------------------------------------------------------------------- +ATTR Grammar + Nonterminals [ | | inhmap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent Attributes} + synmap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent Attributes} ] + +ATTR Nonterminal [ | | inhmap : {Map.Map NontermIdent Attributes} + synmap : {Map.Map NontermIdent Attributes} ] +SEM Nonterminal + | Nonterminal lhs.inhmap = Map.singleton @nt @inh + lhs.synmap = Map.singleton @nt @syn + +------------------------------------------------------------------------------- +-- Output nonterminal type mappings +------------------------------------------------------------------------------- +ATTR Grammar Nonterminals Nonterminal [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map NontermIdent (Map.Map ConstructorIdent (Map.Map Identifier Type))} ] +ATTR Productions Production [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map.Map ConstructorIdent (Map.Map Identifier Type)} ] +ATTR TypeSigs TypeSig [ | | localSigMap USE {`Map.union`} {Map.empty} : {Map Identifier Type} ] + +SEM Nonterminal | Nonterminal lhs.localSigMap = Map.singleton @nt @prods.localSigMap +SEM Production | Production lhs.localSigMap = Map.singleton @con @typeSigs.localSigMap +SEM TypeSig | TypeSig lhs.localSigMap = Map.singleton @name @tp diff --git a/src-ag/ExecutionPlanPre.ag b/src-ag/ExecutionPlanPre.ag --- a/src-ag/ExecutionPlanPre.ag +++ b/src-ag/ExecutionPlanPre.ag @@ -1,15 +1,15 @@ -------------------------------------------------------------------------------- --- Give unique names to rules -------------------------------------------------------------------------------- -ATTR Nonterminal Nonterminals - Production Productions - Rule Rules [ | rulenumber : Int | ] - -SEM Grammar - | Grammar nonts.rulenumber = 0 - -SEM Rule - | Rule lhs.rulenumber = @lhs.rulenumber + 1 - loc.rulename = maybe (identifier $ "rule" ++ show @lhs.rulenumber) id @mbName - - +------------------------------------------------------------------------------- +-- Give unique names to rules +------------------------------------------------------------------------------- +ATTR Nonterminal Nonterminals + Production Productions + Rule Rules [ | rulenumber : Int | ] + +SEM Grammar + | Grammar nonts.rulenumber = 0 + +SEM Rule + | Rule lhs.rulenumber = @lhs.rulenumber + 1 + loc.rulename = maybe (identifier $ "rule" ++ show @lhs.rulenumber) id @mbName + + diff --git a/src-ag/Expression.ag b/src-ag/Expression.ag --- a/src-ag/Expression.ag +++ b/src-ag/Expression.ag @@ -1,12 +1,12 @@ -imports -{ -import UU.Scanner.Position(Pos) -import HsToken -} - -DATA Expression - | Expression pos:{Pos} - tks:{[HsToken]} - -SET AllExpression - = Expression +imports +{ +import UU.Scanner.Position(Pos) +import HsToken +} + +DATA Expression + | Expression pos:{Pos} + tks:{[HsToken]} + +SET AllExpression + = Expression diff --git a/src-ag/GenerateCode.ag b/src-ag/GenerateCode.ag --- a/src-ag/GenerateCode.ag +++ b/src-ag/GenerateCode.ag @@ -1,1191 +1,1191 @@ -PRAGMA strictwrap -PRAGMA strictdata - -INCLUDE "CodeSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "DeclBlocks.ag" - -imports -{ -import CommonTypes -import SequentialTypes -import Code hiding (Type) -import qualified Code -import Options -import CodeSyntax -import ErrorMessages -import GrammarInfo -import DeclBlocks - -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq) -import UU.Scanner.Position -import TokenDef -import HsToken -import HsTokenScanner - -import Data.List(partition,intersperse) -import Data.Maybe(fromJust,isJust) - -} - - -------------------------------------------------------------------------------- --- Options -------------------------------------------------------------------------------- - -ATTR CNonterminals CNonterminal - CProductions CProduction - CVisits CVisit - Sequence CRule - CInterface CSegments CSegment - [ o_unbox,o_sig,o_sem,o_newtypes,o_case,o_pretty,o_rename,o_cata,o_strictwrap,o_splitsems,o_traces,o_costcentre,o_linePragmas,o_monadic,o_clean : Bool - o_data : {Maybe Bool} - prefix : String - options : Options - | | ] -SEM CGrammar [ options : Options | | ] - | CGrammar nonts.o_sig = typeSigs @lhs.options - .o_cata = folds @lhs.options - .o_sem = semfuns @lhs.options - .o_newtypes = newtypes @lhs.options - .o_unbox = unbox @lhs.options - .o_case = cases @lhs.options - .o_pretty = attrInfo @lhs.options - .o_rename = rename @lhs.options - .o_strictwrap = strictWrap @lhs.options - .o_splitsems = splitSems @lhs.options - .o_data = if dataTypes @lhs.options then Just (strictData @lhs.options) else Nothing - .prefix = prefix @lhs.options - .o_traces = genTraces @lhs.options - .o_costcentre = genCostCentres @lhs.options - .o_linePragmas = genLinePragmas @lhs.options - .o_monadic = monadic @lhs.options - .o_clean = clean @lhs.options - -SEM CGrammar | CGrammar - loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @multivisit } - -ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ allPragmas : PragmaMap | | ] - -SEM CGrammar - | CGrammar nonts.allPragmas = @pragmas - -------------------------------------------------------------------------------- --- Passing information about nonterminal and constructor down -------------------------------------------------------------------------------- - -ATTR CProductions CProduction CVisits - CVisit Sequence CRule CInterface - CSegments CSegment [ nt:NontermIdent inh,syn:Attributes | | ] -SEM CNonterminal - | CNonterminal inter.(inh,syn,nt) = (@inh,@syn,@nt) - prods.(inh,syn,nt) = (@inh,@syn,@nt) - -ATTR CVisits CVisit Sequence CRule [ con:ConstructorIdent - terminals : {[Identifier]} | | ] -SEM CProduction - | CProduction visits.con = @con - visits.terminals = @terminals - -ATTR CNonterminals CNonterminal CSegments CSegment CInterface CProductions CProduction CVisits CVisit Sequence CRule [ paramMap : ParamMap | | ] - -SEM CGrammar - | CGrammar nonts.paramMap = @paramMap - - -ATTR CVisits CVisit Sequence CRule [ paramInstMap : {Map Identifier (NontermIdent, [String])} | | ] - -SEM CProduction - | CProduction - loc.paramInstMap = Map.fromList [(nm, (extractNonterminal tp, tps)) | (nm,tp,_) <- @children, let tps = map (cleanupArg @lhs.options) $ nontermArgs tp, not (null tps) ] - -{ --- remove possible @v references in the types of a data type. -cleanupArg :: Options -> String -> String -cleanupArg opts s - = case idEvalType opts (SimpleType s) of - SimpleType s' -> s' - _ -> error "Only SimpleType supported" -} - -ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ contextMap : {ContextMap} quantMap : QuantMap | | ] - -SEM CGrammar - | CGrammar - nonts.contextMap = @contextMap - nonts.quantMap = @quantMap - -{ -appContext :: ContextMap -> NontermIdent -> Code.Type -> Code.Type -appContext mp nt tp - = maybe tp (\ctx -> CtxApp (map (\(n,ns) -> (getName n, ns)) ctx) tp) $ Map.lookup nt mp - -appQuant :: QuantMap -> NontermIdent -> Code.Type -> Code.Type -appQuant mp nt tp - = foldr QuantApp tp $ Map.findWithDefault [] nt mp -} - -ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ allNts : {Set NontermIdent} | | ] - -SEM CGrammar - | CGrammar - nonts.allNts = @nonts.gathNts - -ATTR CNonterminals CNonterminal [ | | gathNts USE {`Set.union`} {Set.empty} : {Set NontermIdent} ] - -SEM CNonterminal - | CNonterminal - lhs.gathNts = Set.singleton @nt - --- keep track of which children have had their first visit -ATTR CVisits CVisit Sequence CRule [ | visitedSet : {Set Identifier} | ] -SEM CProduction | CProduction visits.visitedSet = Set.empty -SEM CRule | CChildVisit loc.visitedSet = Set.insert @name @lhs.visitedSet - -------------------------------------------------------------------------------- --- Generating declarations from the sequence. We generate the origin --- comment if pretty printing is requested. A childvisit takes inherited --- attributes and returns synthesized attributes and the next visit. -------------------------------------------------------------------------------- - -ATTR Sequence CRule [ | | decls USE {++} {[]} : {Decls} ] -SEM CRule - | CRule loc.instTypes = [ (n, (t, mb, for)) | (n, NT t _ for, mb) <- @lhs.children ] - loc.originComment = if @lhs.o_pretty - then (Comment @origin:) - else id - loc.instDecls = [ mkDecl @lhs.o_monadic (Pattern3 (Alias _INST' inst (Underscore (getPos inst)))) - ( let (nm,mb,defor) = fromJust $ inst `lookup` @loc.instTypes - in unwrapSem @lhs.o_newtypes nm - $ case mb of - ChildReplace _ -> App instLocFieldName [SimpleExpr $ fieldname inst] - _ -> - if defor - then SimpleExpr instLocFieldName - else App (cataname @lhs.prefix nm) - [SimpleExpr instLocFieldName] - ) - (Set.singleton instSemFieldName) - (Set.singleton instLocFieldName) - | inst <- @loc.definedInsts - , let instLocFieldName = attrname @lhs.options True _INST inst - instSemFieldName = attrname @lhs.options False _INST' inst - ] - loc.patDescr = if @isIn - then "_" - else concat $ intersperse "," (map (\(f,a) -> show f ++ "." ++ show a) @pattern.patternAttributes) - loc.traceDescr = (maybe "" (\nm -> show nm ++ ":") @mbNamed) ++ show @nt ++ " :: " ++ show @con ++ " :: " ++ @loc.patDescr - - loc.addTrace = \v -> if @lhs.o_traces - then Trace @loc.traceDescr v - else v - loc.costCentreDescr = show @nt ++ ":" ++ show @con ++ ":" ++ @loc.patDescr - loc.addCostCentre = \v -> if @lhs.o_costcentre - then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v - else v - loc.addLinePragma = \v -> let p = getPos @name - hasPos = line p > 0 && column p >= 0 && not (null (file p)) - in if @lhs.o_linePragmas && hasPos - then PragmaExpr True True ("LINE " ++ show (line p) ++ " " ++ show (file p)) - $ LineExpr - $ v - else v - loc.decls = if @hasCode - then @originComment ( mkDecl (@lhs.o_monadic && @explicit) (Pattern3 @pattern.copy) (@loc.addTrace $ @loc.addCostCentre $ @loc.addLinePragma $ (TextExpr @rhs)) - (Set.fromList [attrname @lhs.options False fld nm | (fld,nm,_) <- Map.elems @defines]) - (Set.fromList [attrname @lhs.options True fld nm | (fld,nm) <- Set.toList @uses]) - : @loc.instDecls) - else @loc.instDecls - | CChildVisit loc.costCentreDescr = show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @name ++ ":" ++ show @nt ++ ":" ++ show @nr - loc.addCostCentre = \v -> if @lhs.o_costcentre - then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v - else v - loc.decls = let lhsVars = map (attrname @lhs.options True @name) (Map.keys @syn) - ++ if @isLast then [] else [unwrap ++ funname @name (@nr+1)] - rhsVars = map (attrname @lhs.options False @name) (Map.keys @inh) - unwrap = if @lhs.o_newtypes then typeName @nt (@nr + 1) ++ " " else "" - tuple | isMerging = TupleLhs [locname @lhs.options @name ++ "_comp"] - | otherwise = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars - rhs = @loc.addCostCentre $ Code.InvokeExpr (typeName @nt @nr) (SimpleExpr fun) (map SimpleExpr rhsVars) - isVirtual _ [] = False - isVirtual nm ((n,_,kind) : r) - | nm == n = case kind of - ChildAttr -> True - ChildReplace _ -> True - _ -> False - | otherwise = isVirtual nm r - isMerged = @name `Map.member` @lhs.mergeMap - isMerging = @name `elem` concatMap (\(_,cs) -> cs) (Map.elems @lhs.mergeMap) - merges = [ (c,cs) | (c,(_,cs)) <- Map.assocs @lhs.mergeMap, all (`Set.member` @loc.visitedSet) cs, @name `elem` (c:cs) ] - - baseNm = if @nr == 0 && isVirtual @name @lhs.children - then Ident (getName @name ++ "_inst") (getPos @name) - else @name - fun | @nr == 0 && Set.member @name @lhs.aroundMap - = locname @lhs.options @name ++ "_around " ++ funname baseNm 0 - | otherwise = funname baseNm @nr - outDecls | isMerged = [] -- merged variant is only produced after the last visit of the merged children - | otherwise = -- [mkDecl @lhs.o_monadic tuple rhs (Set.fromList lhsVars) (Set.fromList (funname baseNm @nr : rhsVars))] - if isMerging - then [mkDecl @lhs.o_monadic tuple rhs Set.empty Set.empty] - else [Resume @lhs.o_monadic (typeName @nt @nr) tuple rhs] - outMerged | null merges || @nr /= 0 = [] -- no merged child to produce - | otherwise = let (c,cs) = head merges - tuple' = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars' - lhsVars' = map (attrname @lhs.options True c) (Map.keys @syn) - ++ if @isLast then [] else [unwrap ++ funname c (@nr+1)] - rhsVars' = [ locname @lhs.options c' ++ "_comp" | c' <- cs ] - fun' = locname @lhs.options c ++ "_merge" - rhs' = App fun' (map SimpleExpr rhsVars') - in [Resume @lhs.o_monadic (typeName @nt @nr) tuple' rhs'] - in -- trace (show @name ++ " # " ++ show @loc.visitedSet ++ " # " ++ show (Map.assocs @lhs.mergeMap) ++ " # " ++ show merges ++ " # " ++ show @nr ++ " # " ++ show (length outMerged)) $ - (outDecls ++ outMerged) - -{ -mkDecl :: Bool -> Lhs -> Expr -> Set String -> Set String -> Decl -mkDecl True lhs rhs _ _ = Bind lhs rhs -mkDecl False lhs rhs s1 s2 = Decl lhs rhs s1 s2 - -unwrapSem :: Bool -> NontermIdent -> Expr -> Expr -unwrapSem False _ e = e -unwrapSem True nm e = Case e alts - where alts = [CaseAlt left right] - left = Fun (typeName nm 0) [SimpleExpr "x"] - right = SimpleExpr "x" -} - -ATTR Sequence CRule [ children : {[(Identifier,Type,ChildKind)]} ||] - -ATTR Sequence CRule Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ] -SEM Pattern - | Alias lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts - -SEM CRule - | CRule loc.definedInsts = if @isIn then [] else @pattern.definedInsts - -ATTR Pattern Patterns [ | | patternAttributes USE {++} {[]} : {[(Identifier, Identifier)]} ] -SEM Pattern - | Alias - lhs.patternAttributes = (@field,@attr) : @pat.patternAttributes - -------------------------------------------------------------------------------- --- Numbering the visits -------------------------------------------------------------------------------- - -ATTR CVisits CVisit Sequence CRule - CSegments CSegment [ nr : Int | | ] -SEM CProduction - | CProduction visits.nr = 0 -SEM CVisits - | Cons tl.nr = @lhs.nr + 1 -SEM CInterface - | CInterface seg.nr = 0 -SEM CSegments - | Cons tl.nr = @lhs.nr + 1 - -------------------------------------------------------------------------------- --- Checking last visit -------------------------------------------------------------------------------- - -ATTR CVisit CSegment [ isLast : Bool | | ] -ATTR CVisits CSegments [ | | isNil : Bool ] -SEM CVisits - | Cons lhs.isNil = False - hd.isLast = @tl.isNil - | Nil lhs.isNil = True -SEM CSegments - | Cons lhs.isNil = False - hd.isLast = @tl.isNil - | Nil lhs.isNil = True - -------------------------------------------------------------------------------- --- Getting the next intra-visit dependencies -------------------------------------------------------------------------------- - -ATTR CVisit [ nextIntra : {Exprs} nextIntraVars : {Set String} | | ] -ATTR CVisits CVisit [ | | intra : {Exprs} intraVars : {Set String} ] -SEM CVisit - | CVisit lhs.intra = @intra.exprs - lhs.intraVars = @intra.usedVars -SEM CVisits - | Cons hd.nextIntra = @tl.intra - hd.nextIntraVars = @tl.intraVars - lhs.intra = @hd.intra - lhs.intraVars = @hd.intraVars - | Nil lhs.intra = [] - lhs.intraVars = Set.empty - -------------------------------------------------------------------------------- --- Superfluous intra-visit dependencies due to higher-order children --- (higher-order children can only be passed from their moment of creation) -------------------------------------------------------------------------------- - -SEM CRule - | CChildVisit - loc.isSuperfluousHigherOrderIntra - = @lhs.nr <= Map.findWithDefault (-1) @name @lhs.instVisitNrs - -------------------------------------------------------------------------------- --- Intra-visit dependencies are expressions that need to be passed -------------------------------------------------------------------------------- - -ATTR Sequence CRule [ | | exprs USE {++} {[]} : {Exprs} ] -SEM CRule - | CRule loc.rulename = if @field == _LOC && @name `elem` @lhs.terminals - then funname @name 0 - else attrname @lhs.options @isIn @field @name - lhs.exprs = [SimpleExpr @loc.rulename] - | CChildVisit - loc.names = -- do not pass inst-childs as parameter if they are not defined yet - if @loc.isSuperfluousHigherOrderIntra - then [] - else [funname @name (@nr+1)] - lhs.exprs = let wrap = if @lhs.o_newtypes then \x -> App (typeName @nt (@nr + 1)) [x] else id - - addType expr | null @loc.instParams = expr - | otherwise = TypedExpr expr (@lhs.unfoldSemDom @nt (@nr+1) @loc.instParams) - - in map (wrap . addType . SimpleExpr) @loc.names - -ATTR Sequence CRule [ | | usedVars USE {`Set.union`} {Set.empty} : {Set String} ] -SEM CRule - | CRule - lhs.usedVars = Set.singleton @loc.rulename - | CChildVisit - lhs.usedVars = Set.fromList @loc.names - -------------------------------------------------------------------------------- --- Type signatures are added to the declarations. -------------------------------------------------------------------------------- - -ATTR Sequence CRule [ | | tSigs USE {++} {[]} : {[Decl]} ] -SEM CRule - | CRule loc.mkTp = typeToCodeType (Just @lhs.nt) @loc.orgParams - lhs.tSigs = [ TSig (attrname @lhs.options False field attr) tp' - | (field,attr,tp) <- Map.elems @defines, isJust tp - , let tp1 = @loc.evalTp field $ @mkTp (fromJust tp) - tp' = case findOrigType attr @lhs.children of - Just tp' -> let tp'' = case tp' of - NT n params b -> NT (Ident ("T_" ++ show n) (getPos n)) params b - _ -> tp' - tp2 = @loc.evalTp field $ @mkTp tp'' - in Arr tp2 tp1 - Nothing -> tp1 - findOrigType _ [] = Nothing - findOrigType nm ((n,_,kind) : r) - | nm == n = case kind of - ChildReplace orig -> Just orig - _ -> Nothing - | otherwise = findOrigType nm r - ] - - loc.orgParams = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap - loc.evalTp = - \field tp -> let orgFldParams = map getName $ Map.findWithDefault [] childNt @lhs.paramMap - (childNt,instParams) = Map.findWithDefault (@lhs.nt,[]) field @lhs.paramInstMap - replMap = Map.fromList (zip orgFldParams instParams) - replace k = Map.findWithDefault ('@':k) k replMap - in if null instParams - then if null @orgParams - then tp - else idEvalType @lhs.options tp - else evalType @lhs.options replace tp - - | CChildVisit loc.mkTp = @loc.evalTp . typeToCodeType (Just @nt) @loc.orgParams - loc.definedTps = [ TSig (attrname @lhs.options True @name a) (@mkTp tp) | (a,tp) <- Map.toList @syn ] - loc.nextTp = typeName @nt (@nr+1) - lhs.tSigs = (if @isLast then id else (TSig (funname @name (@nr+1)) (TypeApp (SimpleType @nextTp) (map SimpleType @loc.instParams)) :)) @definedTps - - loc.orgParams = map getName $ Map.findWithDefault [] @nt @lhs.paramMap - loc.instParams = snd $ Map.findWithDefault (@nt,[]) @name @lhs.paramInstMap - loc.replParamMap = Map.fromList (zip @loc.orgParams @loc.instParams) - loc.replace = \k -> Map.findWithDefault k k @loc.replParamMap - loc.evalTp = if null @loc.orgParams then id else evalType @lhs.options @loc.replace - - -------------------------------------------------------------------------------- --- Types of intra-visit dependencies are needed in the type of the --- semantic function. -------------------------------------------------------------------------------- - -ATTR CVisits CVisit [ children : {[(Identifier,Type, ChildKind)]} | | ] -SEM CProduction - | CProduction visits.children = @children - - -ATTR Sequence CRule [ | | tps USE {++} {[]} : {[Type]} - allTpsFound USE {&&} {True} : Bool ] -SEM CRule - | CRule lhs.(tps,allTpsFound) = maybe ([],False) (\tp -> ([tp],True)) @tp - | CChildVisit lhs.tps = if @loc.isSuperfluousHigherOrderIntra - then [] - else [NT (ntOfVisit @nt (@nr+1)) @loc.instParams False] - -------------------------------------------------------------------------------- --- Each visit has its semantic function -------------------------------------------------------------------------------- - -ATTR CVisits [ | | decls : {Decls} ] -ATTR CVisit [ | decls : {Decls} | ] -SEM CVisits - | Nil lhs.decls = [] - | Cons lhs.decls = @hd.decls - hd.decls = @tl.decls - --- Note: lhs.decls are the decls related to the next visit function. We pass it --- chained from right to left in order to build the next visit function inside --- the previous one. --- Note: intra decls are ignored. The intra-visit variables are not passed on --- explicitly, but handled automatically due to nesting level. - -SEM CVisit - | CVisit (loc.higherOrderChildren,loc.firstOrderChildren) = partition (\(_,_,virt) -> isHigherOrder virt) @lhs.children - loc.firstOrderOrig = map pickOrigType @loc.firstOrderChildren - loc.funcname = seqSemname @lhs.prefix @lhs.nt @lhs.con @lhs.nr - loc.nextVisitName = if @lhs.isLast then [] else [visitname @lhs.prefix @lhs.nt (@lhs.nr+1)] - loc.nextVisitDecl = let lhs = TupleLhs @nextVisitName - -- rhs = App fun @lhs.nextIntra - rhs = Let @lhs.decls (SimpleExpr fun) - fun = seqSemname @lhs.prefix @lhs.nt @lhs.con (@lhs.nr+1) - in if @lhs.isLast - then [] - else [Decl lhs rhs (Set.fromList @nextVisitName) @lhs.nextIntraVars] - loc.isOneVisit = @lhs.isLast && @lhs.nr == 0 - loc.hasWrappers = @lhs.nt `Set.member` @lhs.wrappers - loc.refDecls = if @loc.isOneVisit && @loc.hasWrappers && reference @lhs.options - then let synAttrs = Map.toList @syn - synNT = "Syn" ++ "_" ++ getName @lhs.nt - synVars = [ SimpleExpr (attrname @lhs.options False _LHS a) | (a,_) <- synAttrs ] - rhs = App synNT synVars - lhs = Fun "___node" [] - in [Decl lhs rhs Set.empty Set.empty] - else [] - loc.decls = if @lhs.o_clean - then @vss.decls ++ @nextVisitDecl ++ @loc.refDecls -- Don't generate type signatures for Clean, they will cause the compiler to generate functions, even for constants - else @typeSigs ++ @vss.decls ++ @nextVisitDecl ++ @loc.refDecls - vss.lastExpr = mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh) $ map (SimpleExpr . lhsname @lhs.options False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName - intra.lastExpr = error "lastExpr: not used here" - loc.lastExprVars = map (lhsname @lhs.options False) (Map.keys @syn) ++ @loc.nextVisitName - (loc.blockFunDecls, loc.blockFirstFunCall) = mkPartitionedFunction @loc.funcname @loc.o_case @loc.nextVisitDecl @loc.lastExprVars @vss.blockDecls - - loc.costCentreDescr = "b" ++ ":" ++ show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @lhs.nr - loc.addCostCentre = \v -> if @lhs.o_costcentre - then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v - else v - - loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap - loc.semFun = let lhs = Fun @funcname lhs_args - lhs_args = if @lhs.nr == 0 then map field @loc.firstOrderOrig else [] -- @intra.exprs - - field (name,NT tp tps _,_) = let unwrap | @lhs.o_newtypes = \x -> App (sdtype tp) [x] - | otherwise = id - - addType expr | null tps = expr - | otherwise = TypedExpr expr (@lhs.unfoldSemDom tp 0 tps) - - in unwrap $ addType $ SimpleExpr $ funname name 0 - field (name,tp,_) = let expr = SimpleExpr (funname name 0) - in if null @loc.params - then expr - else TypedExpr expr (idEvalType @lhs.options $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp) - - mbEvalTp | null @loc.params = const Nothing - | otherwise = Just . (idEvalType @lhs.options) - - rhs = wrap - . mkSemFun @lhs.nt @lhs.nr [mkLambdaArg (lhsname @lhs.options True nm) (mbEvalTp $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp) | (nm,tp) <- Map.assocs @inh] - $ @loc.addCostCentre - $ if @ordered && @loc.o_splitsems - then @loc.blockFirstFunCall - else mkDecls @loc.declsType @decls - . ResultExpr (typeName @lhs.nt @lhs.nr) - . mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh) - $ map (SimpleExpr . lhsname @lhs.options False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName - wrap = if @lhs.o_newtypes - then \x -> App (typeName @lhs.nt @lhs.nr) [x] - else id - in Decl lhs rhs Set.empty Set.empty - loc.tsig = TSig @funcname @semType - loc.semType = let argType (NT tp tps _) r | tp /= _SELF = typeAppStrs (sdtype tp) tps `Arr` r - | tp == _SELF = error "GenerateCode: found an intra-type with type SELF, which should have been prevented by CRule.tps" - argType (Haskell tp) r = SimpleType tp `Arr` r - argType _ _ = error "Self type not allowed here" - evalTp | null @loc.params = id - | otherwise = idEvalType @lhs.options - - in appQuant @lhs.quantMap @lhs.nt $ appContext @lhs.contextMap @lhs.nt $ evalTp $ - if @lhs.nr == 0 - then foldr argType (typeAppStrs (sdtype @lhs.nt ) @loc.params) (map (\(_,t,_) -> t) @loc.firstOrderOrig) - else foldr argType (typeAppStrs (typeName @lhs.nt @lhs.nr) @loc.params) [] -- @intra.tps - lhs.decls = ( if @lhs.with_sig - then [@tsig, @semFun] - else [@semFun] - ) ++ - ( if @ordered && @loc.o_splitsems - then @loc.blockFunDecls - else [] - ) - loc.typeSigs = if @lhs.o_sig && not @o_case - then @vss.tSigs - else [] - loc.o_do = @ordered && @lhs.o_monadic - loc.o_case = not @loc.o_do && @lhs.o_case && @ordered && not (hasPragma @lhs.allPragmas @lhs.nt @lhs.con _NOCASE) - loc.declsType = if @loc.o_do - then DeclsDo - else if @loc.o_case - then DeclsCase - else DeclsLet - loc.o_splitsems = @ordered && @lhs.o_splitsems - -{ -mkLambdaArg :: String -> Maybe Code.Type -> Expr -mkLambdaArg nm Nothing = SimpleExpr nm -mkLambdaArg nm (Just tp) = TypedExpr (SimpleExpr nm) tp - -mkLambda :: Exprs -> Expr -> Expr -mkLambda [] e = e -mkLambda xs e = Lambda xs e - -mkSemFun :: Identifier -> Int -> Exprs -> Expr -> Expr -mkSemFun nt nr xs e = SemFun (typeName nt nr) xs e - -typeAppStrs :: String -> [String] -> Code.Type -typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params) - -isHigherOrder :: ChildKind -> Bool -isHigherOrder ChildAttr = True -isHigherOrder _ = False - -pickOrigType :: (Identifier, Type, ChildKind) -> (Identifier, Type, ChildKind) -pickOrigType (nm, _, virt@(ChildReplace x)) = (nm, x, virt) -pickOrigType x = x -} - -ATTR CVisits CVisit Sequence CRule [ instVisitNrs : {Map Identifier Int} || ] -ATTR CVisits CVisit [|| gatherInstVisitNrs USE {`Map.union`} {Map.empty} : {Map Identifier Int} ] -SEM CProduction - | CProduction - visits.instVisitNrs = @visits.gatherInstVisitNrs - -SEM CVisit - | CVisit - lhs.gatherInstVisitNrs = Map.fromList [(i,@lhs.nr) | i <- @vss.definedInsts] - -------------------------------------------------------------------------------- --- Push aroundsMap downward -------------------------------------------------------------------------------- - -ATTR CNonterminals CNonterminal - [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Set Identifier))} || ] - -ATTR CProductions CProduction - [ aroundMap : {Map ConstructorIdent (Set Identifier)} || ] - -ATTR CVisits CVisit Sequence CRule [ aroundMap : {Set Identifier} | | ] - -SEM CGrammar | CGrammar loc.aroundMap = @aroundsMap -SEM CNonterminal | CNonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap -SEM CProduction | CProduction loc.aroundMap = Map.findWithDefault Set.empty @con @lhs.aroundMap - -------------------------------------------------------------------------------- --- Push mergeMap downward -------------------------------------------------------------------------------- - -ATTR CNonterminals CNonterminal - [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))} || ] - -ATTR CProductions CProduction - [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))} || ] - -ATTR CVisits CVisit Sequence CRule [ mergeMap : {Map Identifier (Identifier, [Identifier])} | | ] - -SEM CGrammar | CGrammar loc.mergeMap = @mergeMap -SEM CNonterminal | CNonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap -SEM CProduction | CProduction loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap - -------------------------------------------------------------------------------- --- Generate a partitioned version of the sequence of rules -------------------------------------------------------------------------------- - -ATTR Sequence [ lastExpr : Expr | | blockDecls : DeclBlocks ] - -ATTR Sequence CRule [ | declsAbove : {[Decl]} | ] -SEM CVisit - | CVisit - vss.declsAbove = [] - intra.declsAbove = error "declsAbove: not used here" - -SEM CRule - | CRule - lhs.declsAbove = @lhs.declsAbove ++ @loc.decls - | CChildVisit - lhs.declsAbove = [] - -SEM Sequence - | Cons - lhs.blockDecls = @hd.bldBlocksFun @tl.blockDecls - | Nil - lhs.blockDecls = DeclTerminator @lhs.declsAbove @lhs.lastExpr - -ATTR CRule [ | | bldBlocksFun : {DeclBlocks -> DeclBlocks} ] -SEM CRule - | CRule - lhs.bldBlocksFun = id - | CChildVisit - lhs.bldBlocksFun = DeclBlock @lhs.declsAbove (head @loc.decls) - -{ -mkPartitionedFunction :: String -> Bool -> [Decl] -> [String] -> DeclBlocks -> ([Decl], Expr) -mkPartitionedFunction prefix' optCase nextVisitDecls lastExprVars cpsTree - = let inh = Inh_DeclBlocksRoot { prefix_Inh_DeclBlocksRoot = prefix' - , optCase_Inh_DeclBlocksRoot = optCase - , nextVisitDecls_Inh_DeclBlocksRoot = nextVisitDecls - , lastExprVars_Inh_DeclBlocksRoot = lastExprVars - } - sem = sem_DeclBlocksRoot (DeclBlocksRoot cpsTree) - syn = wrap_DeclBlocksRoot sem inh - in (lambdas_Syn_DeclBlocksRoot syn, firstCall_Syn_DeclBlocksRoot syn) -} - -WRAPPER DeclBlocksRoot - -ATTR DeclBlocksRoot DeclBlocks [ prefix : String optCase : Bool nextVisitDecls : {[Decl]} lastExprVars : {[String]} | | ] -ATTR DeclBlocksRoot [ | | lambdas : {[Decl]} firstCall : Expr ] - -SEM DeclBlocksRoot - | DeclBlocksRoot - lhs.lambdas = @blocks.decls - lhs.firstCall = @blocks.callExpr - -ATTR DeclBlocks [ blockNr : Int | | ] -SEM DeclBlocksRoot - | DeclBlocksRoot - blocks.blockNr = 1 -SEM DeclBlocks - | DeclBlock - next.blockNr = @lhs.blockNr + 1 - -ATTR DeclBlocks [ | | callExpr : Expr freeVars : {[String]} ] -SEM DeclBlocks - | DeclBlock DeclTerminator - loc.lambdaName = @lhs.prefix ++ "_block" ++ show @lhs.blockNr - loc.pragmaDecl = PragmaDecl ("NOINLINE " ++ @loc.lambdaName) - lhs.callExpr = App @loc.lambdaName (map SimpleExpr @loc.freeVars) - | DeclTerminator - loc.freeVars = freevars @lhs.lastExprVars (@defs ++ @lhs.nextVisitDecls) - | DeclBlock - loc.freeVars = freevars @next.freeVars (@visit : @defs) - -ATTR DeclBlocks [ | | decls : {[Decl]} ] -SEM DeclBlocks - | DeclTerminator - lhs.decls = [ mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ @lhs.nextVisitDecls) @result ] - | DeclBlock - loc.decl = mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ [@visit]) @next.callExpr - lhs.decls = (if @lhs.blockNr > 1 then [@loc.pragmaDecl] else []) ++ [@loc.decl] ++ @next.decls - -{ -freevars :: [String] -> [Decl] -> [String] -freevars additional decls - = Set.toList (allused `Set.difference` alldefined) - where - allused = Set.unions (Set.fromList additional : map usedvars decls) - alldefined = Set.unions (map definedvars decls) - - usedvars (Decl _ _ _ uses) = uses - usedvars _ = Set.empty - - definedvars (Decl _ _ defs _) = defs - definedvars _ = Set.empty - -mkBlockLambda :: Bool -> String -> [String] -> [Decl] -> Expr -> Decl -mkBlockLambda optCase name args decls expr - = Decl lhs rhs Set.empty Set.empty - where - lhs = Fun name (map SimpleExpr args) - rhs = mkLet optCase decls expr -} - - -------------------------------------------------------------------------------- --- The semantic domain is generated from the interface. -------------------------------------------------------------------------------- - -ATTR CInterface CSegments CSegment [ | | semDom USE {++} {[]} : {[Decl]} ] -SEM CInterface - | CInterface lhs.semDom = Comment "semantic domain" : @seg.semDom - -SEM CSegment - | CSegment loc.altSemForm = breadthFirst @lhs.options - loc.tp = if @loc.altSemForm - then TypeApp (SimpleType "Child") [SimpleType "EvalInfo", @loc.indexExpr ] - else foldr Arr @loc.synTps @loc.inhTps - loc.inhTps = [typeToCodeType (Just @lhs.nt) @loc.params tp | tp <- Map.elems @inh] - loc.inhTup = mkTupleType @lhs.o_unbox (null @loc.inhTps) @loc.inhTps - loc.synTps = mkTupleType @lhs.o_unbox (null @loc.inhTps) ([typeToCodeType (Just @lhs.nt) @loc.params tp | tp <- Map.elems @syn] ++ @loc.continuation) - loc.curTypeName = typeName @lhs.nt @lhs.nr - loc.nextTypeName = typeName @lhs.nt (@lhs.nr + 1) - loc.indexName = "I_" ++ @loc.curTypeName - loc.dataIndex = Code.Data @loc.indexName @loc.params [DataAlt @loc.indexName []] False [] - loc.indexExpr = TypeApp (SimpleType @loc.indexName) (map (SimpleType . ('@':)) @loc.params) - loc.indexStr = "(" ++ @loc.indexName ++ concatMap (\p -> " " ++ p) @loc.params ++ ")" - loc.inhInstance = Code.Data "instance Inh" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Inh") [@loc.inhTup] ] False [] - loc.synInstance = Code.Data "instance Syn" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Syn") [@loc.synTps] ] False [] - loc.continuation = if @lhs.isLast - then [] - else [TypeApp (SimpleType @loc.nextTypeName) (map (SimpleType . ('@':)) @loc.params)] - loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap - lhs.semDom = let name = typeName @lhs.nt @lhs.nr - evalTp | null @loc.params = id - | otherwise = idEvalType @lhs.options - in ( if @lhs.o_newtypes - then [ Code.NewType name @loc.params name (evalTp @loc.tp) ] - else [ Code.Type name @loc.params (evalTp @loc.tp) ] ) - ++ ( if @loc.altSemForm - then [@loc.dataIndex, @loc.inhInstance, @loc.synInstance] - else [] ) - -ATTR CNonterminals CNonterminal CInterface CSegments CSegment [ | | semDomUnfoldGath USE {`Map.union`} {Map.empty} : {Map (NontermIdent, Int) ([String], Code.Type)} ] - -SEM CSegment - | CSegment - lhs.semDomUnfoldGath = Map.singleton (@lhs.nt, @lhs.nr) (@loc.params, @loc.tp) - -ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ unfoldSemDom : {NontermIdent -> Int -> [String] -> Code.Type} | | ] - -SEM CGrammar - | CGrammar - loc.unfoldSemDom = - \nt nr repl -> - let (params, tp) = Map.findWithDefault (error ("No such semantic domain: " ++ show nt)) (nt, nr) @nonts.semDomUnfoldGath - replMap = Map.fromList (zip params repl) - replace k = Map.findWithDefault ('@':k) k replMap - in evalType @lhs.options replace tp - -{ -typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type -typeToCodeType _ _ tp - = case tp of - NT nt tps defor -> NontermType (getName nt) tps defor - Haskell t -> SimpleType t - Self -> error "Self type not allowed here." - -evalType :: Options -> (String -> String) -> Code.Type -> Code.Type -evalType opts replf t' - = chase t' - where - chase t - = case t of - Arr l r -> Arr (chase l) (chase r) - TypeApp f as -> TypeApp (chase f) (map chase as) - TupleType tps -> TupleType (map chase tps) - UnboxedTupleType tps -> UnboxedTupleType (map chase tps) - Code.List tp -> Code.List (chase tp) - SimpleType txt -> let tks = lexTokens opts (initPos txt) txt - tks' = map replaceTok tks - txt' = unlines . showTokens . tokensToStrings $ tks' - in SimpleType txt' - TMaybe m -> TMaybe (chase m) - TEither l r -> TEither (chase l) (chase r) - TMap k v -> TMap (chase k) (chase v) - TIntMap v -> TIntMap (chase v) - TSet m -> TSet (chase m) - _ -> t - - replaceTok t - = case t of - AGLocal v p _ -> HsToken (replf $ getName v) p - _ -> t - -idEvalType :: Options -> Code.Type -> Code.Type -idEvalType options = evalType options id -} - -------------------------------------------------------------------------------- --- Wrapper functions -------------------------------------------------------------------------------- - -SEM CNonterminal - | CNonterminal loc.semWrapper = let params' = map getName @params - inhAttrs = Map.toList @inh - synAttrs = Map.toList @syn - inhVars = [ SimpleExpr (attrname @lhs.options True _LHS a) | (a,_) <- inhAttrs ] - synVars = [ SimpleExpr (attrname @lhs.options False _LHS a) | (a,_) <- synAttrs ] - var = "sem" - wrapNT = "wrap" ++ "_" ++ getName @nt - inhNT = "Inh" ++ "_" ++ getName @nt - synNT = "Syn" ++ "_" ++ getName @nt - varPat = if @lhs.o_newtypes - then App (sdtype @nt) [SimpleExpr var] - else SimpleExpr var - - evalTp | null params' = id - | otherwise = idEvalType @lhs.options - appParams nm = TypeApp (SimpleType nm) (map SimpleType params') - typeSig = TSig wrapNT (evalTp $ appParams (sdtype @nt) `Arr` (appParams inhNT `Arr` appParams synNT)) - mkstrict = Named @lhs.o_strictwrap - mkdata n attrs = Data n params' [Record n [mkstrict (getName f++"_"++n) $ evalTp $ typeToCodeType (Just @nt) params' t | (f,t) <- attrs]] False [] - datas = [mkdata inhNT inhAttrs, mkdata synNT synAttrs] - in datas ++ [ typeSig - , Decl (Fun wrapNT [varPat, App inhNT inhVars]) - (Let @inter.wrapDecls (App synNT synVars)) - Set.empty Set.empty - ] - -ATTR CInterface CSegments CSegment [ | | wrapDecls USE {++} {[]}: {Decls} ] -SEM CSegment - | CSegment lhs.wrapDecls = let lhsVars = map (lhsname @lhs.options False) (Map.keys @syn) - ++ if @lhs.isLast then [] else [unwrap ++ sem (@lhs.nr+1)] - rhsVars = map (lhsname @lhs.options True) (Map.keys @inh) - rhs = map SimpleExpr rhsVars - unwrap = if @lhs.o_newtypes then typeName @lhs.nt (@lhs.nr + 1) ++ " " else "" - var = "sem" - sem 0 = var - sem n = var ++ "_" ++ show n - ntt = typeName @lhs.nt @lhs.nr - in [ EvalDecl ntt (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (InvokeExpr ntt (SimpleExpr $ sem @lhs.nr) rhs) ] - -- [ Decl (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (App (sem @lhs.nr) rhs) (Set.fromList lhsVars) (Set.fromList rhsVars) ] - -------------------------------------------------------------------------------- --- Errors for missing type signatures. It's an error when one of the --- attributes in the intra-visit dependencies does not have a type. --- UPDATE: it is not an error anymore... -------------------------------------------------------------------------------- - -ATTR CNonterminals CNonterminal - CProductions CProduction - CVisits CVisit [ with_sig : Bool | | ] - -SEM CGrammar - | CGrammar nonts.with_sig = typeSigs @lhs.options - -SEM CGrammar [ | | errors : {Seq Error} ] - | CGrammar lhs.errors = Seq.empty - -------------------------------------------------------------------------------- --- Provide a description of the interfaces as comments -------------------------------------------------------------------------------- - -SEM CNonterminal - | CNonterminal loc.comment = Comment . unlines . map ind $ ( @inter.comments ++ ("alternatives:" : map ind @prods.comments) ) - -ATTR CInterface CSegments CSegment - CProductions CProduction - CVisits CVisit Sequence CRule [ | | comments USE {++} {[]}: {[String]} ] - -ATTR Sequence CRule [ what:String | | ] - -SEM CSegment - | CSegment lhs.comments = let body = map ind (showsSegment (CSegment @inh @syn)) - in if null body - then [] - else ("visit " ++ show @lhs.nr ++ ":") : body - -SEM CProduction - | CProduction loc.firstOrderChildren = [ (nm,fromJust mb,virt) | (nm,tp,virt) <- @children, let mb = isFirstOrder virt tp, isJust mb ] - lhs.comments = ("alternative " ++ getName @con ++ ":") - : map ind ( map (\(x,y,_) -> makeLocalComment 14 "child" x (Just y)) @loc.firstOrderChildren - ++ @visits.comments - ) - -{ --- for a virtual child that already existed as a child, returns -isFirstOrder :: ChildKind -> Type -> Maybe Type -isFirstOrder ChildSyntax tp = Just tp -isFirstOrder ChildAttr _ = Nothing -isFirstOrder (ChildReplace tp) _ = Just tp -} - -SEM CVisit - | CVisit lhs.comments = let body = map ind (@vss.comments ++ @intra.comments) - in if null body - then [] - else ("visit " ++ show @lhs.nr ++ ":") : body - vss.what = "local" - intra.what = "intra" - - -SEM CRule - | CRule lhs.comments = [ makeLocalComment 11 @lhs.what name tp | (field,name,tp) <- Map.elems @defines, field == _LOC ] - ++ [ makeLocalComment 11 "inst " name tp | (field,name,tp) <- Map.elems @defines, field == _INST ] - -{ -makeLocalComment :: Int -> String -> Identifier -> Maybe Type -> String -makeLocalComment width what name tp = let x = getName name - y = maybe "_" (\t -> case t of - (NT nt tps _) -> getName nt ++ " " ++ unwords tps - Haskell t' -> '{' : t' ++ "}" - Self -> error "Self type not allowed here.") tp - in ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y ) - -} - -------------------------------------------------------------------------------- --- And tie it all together -------------------------------------------------------------------------------- - -ATTR CNonterminals CNonterminal [ | | chunks USE {++} {[]} : {Chunks} ] -ATTR CProductions CProduction [ | | decls USE {++} {[]} : {Decls} ] -ATTR CGrammar [ | | output : Program ] - -SEM CGrammar - | CGrammar lhs.output = Program @nonts.chunks @multivisit - -SEM CNonterminal - | CNonterminal lhs.chunks = [ Chunk (getName @nt) - (Comment (getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')) - (if @lhs.o_pretty then [@loc.comment] else []) - (if isJust @lhs.o_data then [@loc.dataDef] else []) - (if @lhs.o_cata && @loc.genCata then @loc.cataFun else []) - (if @lhs.o_sig then @inter.semDom else []) - (if @nt `Set.member` @lhs.wrappers then @loc.semWrapper else []) - (if @lhs.o_sem then @prods.decls else []) - (if @lhs.o_sem then @prods.semNames else []) - ] - -{ --- Lets or nested Cases? --- or even a do-expression? - -data DeclsType = DeclsLet | DeclsCase | DeclsDo - -mkDecls :: DeclsType -> Decls -> Expr -> Expr -mkDecls DeclsLet = mkLet False -mkDecls DeclsCase = mkLet True -mkDecls DeclsDo = \decls -> Do (map toBind decls) - where toBind (Decl lhs rhs _ _) = BindLet lhs rhs - toBind d = d - -mkLet :: Bool -> Decls -> Expr -> Expr -mkLet False decls body = Let decls body -mkLet True decls body = foldr oneCase body decls - -oneCase :: Decl -> Expr -> Expr -oneCase (Decl left rhs _ _) ex = Case rhs [CaseAlt left ex] -oneCase (Resume _ nt left rhs) ex = ResumeExpr nt rhs left ex -oneCase _ ex = ex - --- Gives the name of the visit function -funname :: Show a => a -> Int -> String -funname field 0 = show field ++ "_" -funname field nr = show field ++ "_" ++ show nr - --- Gives the name of a semantic function -seqSemname :: String -> NontermIdent -> ConstructorIdent -> Int -> String -seqSemname pre nt con 0 = semname pre nt con -seqSemname pre nt con nr = semname pre nt con ++ "_" ++ show nr - --- Gives the name of a type -typeName :: NontermIdent -> Int -> String -typeName nt 0 = "T_" ++ show nt -typeName nt n = "T_" ++ show nt ++ "_" ++ show n - -ntOfVisit :: NontermIdent -> Int -> NontermIdent -ntOfVisit nt 0 = nt -ntOfVisit nt n = Ident (show nt ++ "_" ++ show n) (getPos nt) - --- Gives the name of a visit function -visitname :: String -> NontermIdent -> Int -> String -visitname pre nt n = pre ++ getName nt ++ "_" ++ show n -} - -------------------------------------------------------------------------------- --- Datatypes were already present -------------------------------------------------------------------------------- - -ATTR CNonterminals CNonterminal [ derivings: {Derivings} typeSyns : {TypeSyns} | | ] -ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ wrappers:{Set NontermIdent} | | ] - -SEM CGrammar - | CGrammar nonts . typeSyns = @typeSyns - . derivings = @derivings - . wrappers = @wrappers - -SEM CNonterminal - | CNonterminal loc.dataDef = let params' = map getName @params - typeSyn tp = let theType = - case tp of - CommonTypes.Maybe t -> TMaybe $ typeToCodeType (Just @nt) params' t - CommonTypes.Either t1 t2 -> TEither (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2) - CommonTypes.Map t1 t2 -> TMap (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2) - CommonTypes.IntMap t -> TIntMap $ typeToCodeType (Just @nt) params' t - CommonTypes.List t -> Code.List $ typeToCodeType (Just @nt) params' t - CommonTypes.Tuple ts -> Code.TupleType [typeToCodeType (Just @nt) params' t | (_,t) <- ts ] - CommonTypes.OrdSet t -> TSet $ typeToCodeType (Just @nt) params' t - CommonTypes.IntSet -> TIntSet - in Code.Type (getName @nt) params' (idEvalType @lhs.options theType) - derivings = maybe [] (map getName . Set.toList) (Map.lookup @nt @lhs.derivings) - dataDef = Data (getName @nt) (map getName @params) @prods.dataAlts (maybe False id @lhs.o_data) derivings - in maybe dataDef typeSyn $ lookup @nt @lhs.typeSyns - -ATTR CProductions [ | | dataAlts : {DataAlts} ] -ATTR CProduction [ | | dataAlt : {DataAlt} ] - -SEM CProductions - | Cons lhs.dataAlts = @hd.dataAlt : @tl.dataAlts - | Nil lhs.dataAlts = [] - -SEM CProduction - | CProduction loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap - lhs.dataAlt = let conNm = conname @lhs.o_rename @lhs.nt @con - mkFields :: (NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> a) -> [a] - mkFields f = map (\(nm,t,_) -> f @lhs.nt @con nm (typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested t)) @loc.firstOrderChildren - in if dataRecords @lhs.options - then Record conNm $ mkFields $ toNamedType (strictData @lhs.options) - else DataAlt conNm $ mkFields $ \_ _ _ t -> t - -{ -toNamedType :: Bool -> NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> Code.NamedType -toNamedType genStrict nt con nm tp - = Code.Named genStrict strNm tp - where strNm = recordFieldname nt con nm -} - -------------------------------------------------------------------------------- --- Catamorphism were already present -------------------------------------------------------------------------------- - -SEM CNonterminal - | CNonterminal loc.genCata = not (@nt `Set.member` nocatas @lhs.options) - loc.cataFun = let appParams nm = TypeApp (SimpleType nm) (map SimpleType (map getName @params)) - evalTp | null @params = id - | otherwise = idEvalType @lhs.options - tSig = TSig (cataname @lhs.prefix @nt) - (appQuant @lhs.quantMap @nt $ appContext @lhs.contextMap @nt $ evalTp $ appParams (getName @nt) `Arr` appParams (sdtype @nt)) - special typ = case typ of - CommonTypes.List tp -> - let cons = SimpleExpr (semname @lhs.prefix @nt (identifier "Cons")) - nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" )) - arg = SimpleExpr "list" - rarg = case tp of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in SimpleExpr ("(Prelude.map " ++ (cataname @lhs.prefix t') ++ " list)") - _ -> arg - lhs = Fun (cataname @lhs.prefix @nt) [arg] - rhs = (App "Prelude.foldr" [cons,nil,rarg]) - in [Decl lhs rhs Set.empty Set.empty] - CommonTypes.Maybe tp -> - let just = semname @lhs.prefix @nt (identifier "Just") - nothing = semname @lhs.prefix @nt (identifier "Nothing" ) - arg = SimpleExpr "x" - rarg = case tp of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App (cataname @lhs.prefix t') [arg] - _ -> arg - lhs a = Fun (cataname @lhs.prefix @nt) [a] - in [Decl (lhs (App "Prelude.Just" [arg])) (App just [rarg]) Set.empty Set.empty - ,Decl (lhs (SimpleExpr "Prelude.Nothing")) (SimpleExpr nothing) Set.empty Set.empty - ] - CommonTypes.Either tp1 tp2 -> - let left = semname @lhs.prefix @nt (identifier "Left") - right = semname @lhs.prefix @nt (identifier "Right" ) - arg = SimpleExpr "x" - rarg0 = case tp1 of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App (cataname @lhs.prefix t') [arg] - _ -> arg - rarg1 = case tp2 of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App (cataname @lhs.prefix t') [arg] - _ -> arg - lhs a = Fun (cataname @lhs.prefix @nt) [a] - in [Decl (lhs (App "Prelude.Left" [arg])) (App left [rarg0]) Set.empty Set.empty - ,Decl (lhs (App "Prelude.Right" [arg])) (App right [rarg1]) Set.empty Set.empty - ] - CommonTypes.Map _ tp -> - let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry")) - nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil")) - arg = SimpleExpr "m" - rarg = case tp of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App "Data.Map.map" [SimpleExpr $ cataname @lhs.prefix t', arg] - _ -> arg - lhs = Fun (cataname @lhs.prefix @nt) [arg] - rhs = App "Data.Map.foldrWithKey" [entry,nil,rarg] - in [Decl lhs rhs Set.empty Set.empty] - CommonTypes.IntMap tp -> - let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry")) - nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil")) - arg = SimpleExpr "m" - rarg = case tp of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App "Data.IntMap.map" [SimpleExpr $ cataname @lhs.prefix t', arg] - _ -> arg - lhs = Fun (cataname @lhs.prefix @nt) [arg] - rhs = App "Data.IntMap.foldWithKey" [entry,nil,rarg] - in [Decl lhs rhs Set.empty Set.empty] - CommonTypes.Tuple tps -> - let con = semname @lhs.prefix @nt (identifier "Tuple") - tps' = [ (SimpleExpr (getName x),y) | (x,y) <- tps] - rargs = map rarg tps' - rarg (n, tp) = case tp of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App (cataname @lhs.prefix t') [n] - _ -> n - - lhs = Fun (cataname @lhs.prefix @nt) [TupleExpr (map fst tps')] - rhs = App con rargs - in [Decl lhs rhs Set.empty Set.empty] - CommonTypes.OrdSet tp -> - let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry")) - nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" )) - arg = SimpleExpr "set" - rentry = case tp of - NT t _ _ -> let t' = maybe t id (deforestedNt t) - in App "(.)" [entry, SimpleExpr $ cataname @lhs.prefix t'] - _ -> entry - lhs = Fun (cataname @lhs.prefix @nt) [arg] - rhs = (App "Data.Set.foldr" [rentry,nil,arg]) - in [Decl lhs rhs Set.empty Set.empty] - CommonTypes.IntSet -> - let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry")) - nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" )) - arg = SimpleExpr "set" - lhs = Fun (cataname @lhs.prefix @nt) [arg] - rhs = (App "Data.IntSet.foldr" [entry,nil,arg]) - in [Decl lhs rhs Set.empty Set.empty] - in Comment "cata" : - (if @lhs.o_sig then [tSig] else []) ++ - maybe @prods.cataAlts special (lookup @nt @lhs.typeSyns) - -ATTR CProductions [ | | cataAlts : {Decls} ] -ATTR CProduction [ | | cataAlt : {Decl} ] - - -SEM CProductions - | Cons lhs.cataAlts = @hd.cataAlt : @tl.cataAlts - | Nil lhs.cataAlts = [] - -SEM CProduction - | CProduction lhs.cataAlt = let lhs = Fun (cataname @lhs.prefix @lhs.nt) [lhs_pat] - lhs_pat = App (conname @lhs.o_rename @lhs.nt @con) - (map (\(n,_,_) -> SimpleExpr $ locname @lhs.options $ n) @loc.firstOrderChildren) - rhs = App (semname @lhs.prefix @lhs.nt @con) - (map argument @loc.firstOrderChildren) - argument (nm,NT tp _ _,_) = App (cataname @lhs.prefix tp) - [SimpleExpr (locname @lhs.options nm)] - argument (nm, _,_) = SimpleExpr (locname @lhs.options nm) - in Decl lhs rhs Set.empty Set.empty - - -------------------------------------------------------------------------------- --- Collect names of generated stuff -------------------------------------------------------------------------------- - -ATTR CProductions CProduction CVisits CVisit [ | | semNames USE {++} {[]} : {[String]} ] - -{- -SEM CProduction - | CProduction - lhs.semNames = [cataname @lhs.prefix @lhs.nt] ++ @visits.semNames --} - -SEM CVisit - | CVisit - lhs.semNames = [@loc.funcname] - +PRAGMA strictwrap +PRAGMA strictdata + +INCLUDE "CodeSyntax.ag" +INCLUDE "Patterns.ag" +INCLUDE "DeclBlocks.ag" + +imports +{ +import CommonTypes +import SequentialTypes +import Code hiding (Type) +import qualified Code +import Options +import CodeSyntax +import ErrorMessages +import GrammarInfo +import DeclBlocks + +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Set as Set +import Data.Set(Set) +import qualified Data.Sequence as Seq +import Data.Sequence(Seq) +import UU.Scanner.Position +import TokenDef +import HsToken +import HsTokenScanner + +import Data.List(partition,intersperse) +import Data.Maybe(fromJust,isJust) + +} + + +------------------------------------------------------------------------------- +-- Options +------------------------------------------------------------------------------- + +ATTR CNonterminals CNonterminal + CProductions CProduction + CVisits CVisit + Sequence CRule + CInterface CSegments CSegment + [ o_unbox,o_sig,o_sem,o_newtypes,o_case,o_pretty,o_rename,o_cata,o_strictwrap,o_splitsems,o_traces,o_costcentre,o_linePragmas,o_monadic,o_clean : Bool + o_data : {Maybe Bool} + prefix : String + options : Options + | | ] +SEM CGrammar [ options : Options | | ] + | CGrammar nonts.o_sig = typeSigs @lhs.options + .o_cata = folds @lhs.options + .o_sem = semfuns @lhs.options + .o_newtypes = newtypes @lhs.options + .o_unbox = unbox @lhs.options + .o_case = cases @lhs.options + .o_pretty = attrInfo @lhs.options + .o_rename = rename @lhs.options + .o_strictwrap = strictWrap @lhs.options + .o_splitsems = splitSems @lhs.options + .o_data = if dataTypes @lhs.options then Just (strictData @lhs.options) else Nothing + .prefix = prefix @lhs.options + .o_traces = genTraces @lhs.options + .o_costcentre = genCostCentres @lhs.options + .o_linePragmas = genLinePragmas @lhs.options + .o_monadic = monadic @lhs.options + .o_clean = clean @lhs.options + +SEM CGrammar | CGrammar + loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @multivisit } + +ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ allPragmas : PragmaMap | | ] + +SEM CGrammar + | CGrammar nonts.allPragmas = @pragmas + +------------------------------------------------------------------------------- +-- Passing information about nonterminal and constructor down +------------------------------------------------------------------------------- + +ATTR CProductions CProduction CVisits + CVisit Sequence CRule CInterface + CSegments CSegment [ nt:NontermIdent inh,syn:Attributes | | ] +SEM CNonterminal + | CNonterminal inter.(inh,syn,nt) = (@inh,@syn,@nt) + prods.(inh,syn,nt) = (@inh,@syn,@nt) + +ATTR CVisits CVisit Sequence CRule [ con:ConstructorIdent + terminals : {[Identifier]} | | ] +SEM CProduction + | CProduction visits.con = @con + visits.terminals = @terminals + +ATTR CNonterminals CNonterminal CSegments CSegment CInterface CProductions CProduction CVisits CVisit Sequence CRule [ paramMap : ParamMap | | ] + +SEM CGrammar + | CGrammar nonts.paramMap = @paramMap + + +ATTR CVisits CVisit Sequence CRule [ paramInstMap : {Map Identifier (NontermIdent, [String])} | | ] + +SEM CProduction + | CProduction + loc.paramInstMap = Map.fromList [(nm, (extractNonterminal tp, tps)) | (nm,tp,_) <- @children, let tps = map (cleanupArg @lhs.options) $ nontermArgs tp, not (null tps) ] + +{ +-- remove possible @v references in the types of a data type. +cleanupArg :: Options -> String -> String +cleanupArg opts s + = case idEvalType opts (SimpleType s) of + SimpleType s' -> s' + _ -> error "Only SimpleType supported" +} + +ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ contextMap : {ContextMap} quantMap : QuantMap | | ] + +SEM CGrammar + | CGrammar + nonts.contextMap = @contextMap + nonts.quantMap = @quantMap + +{ +appContext :: ContextMap -> NontermIdent -> Code.Type -> Code.Type +appContext mp nt tp + = maybe tp (\ctx -> CtxApp (map (\(n,ns) -> (getName n, ns)) ctx) tp) $ Map.lookup nt mp + +appQuant :: QuantMap -> NontermIdent -> Code.Type -> Code.Type +appQuant mp nt tp + = foldr QuantApp tp $ Map.findWithDefault [] nt mp +} + +ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ allNts : {Set NontermIdent} | | ] + +SEM CGrammar + | CGrammar + nonts.allNts = @nonts.gathNts + +ATTR CNonterminals CNonterminal [ | | gathNts USE {`Set.union`} {Set.empty} : {Set NontermIdent} ] + +SEM CNonterminal + | CNonterminal + lhs.gathNts = Set.singleton @nt + +-- keep track of which children have had their first visit +ATTR CVisits CVisit Sequence CRule [ | visitedSet : {Set Identifier} | ] +SEM CProduction | CProduction visits.visitedSet = Set.empty +SEM CRule | CChildVisit loc.visitedSet = Set.insert @name @lhs.visitedSet + +------------------------------------------------------------------------------- +-- Generating declarations from the sequence. We generate the origin +-- comment if pretty printing is requested. A childvisit takes inherited +-- attributes and returns synthesized attributes and the next visit. +------------------------------------------------------------------------------- + +ATTR Sequence CRule [ | | decls USE {++} {[]} : {Decls} ] +SEM CRule + | CRule loc.instTypes = [ (n, (t, mb, for)) | (n, NT t _ for, mb) <- @lhs.children ] + loc.originComment = if @lhs.o_pretty + then (Comment @origin:) + else id + loc.instDecls = [ mkDecl @lhs.o_monadic (Pattern3 (Alias _INST' inst (Underscore (getPos inst)))) + ( let (nm,mb,defor) = fromJust $ inst `lookup` @loc.instTypes + in unwrapSem @lhs.o_newtypes nm + $ case mb of + ChildReplace _ -> App instLocFieldName [SimpleExpr $ fieldname inst] + _ -> + if defor + then SimpleExpr instLocFieldName + else App (cataname @lhs.prefix nm) + [SimpleExpr instLocFieldName] + ) + (Set.singleton instSemFieldName) + (Set.singleton instLocFieldName) + | inst <- @loc.definedInsts + , let instLocFieldName = attrname @lhs.options True _INST inst + instSemFieldName = attrname @lhs.options False _INST' inst + ] + loc.patDescr = if @isIn + then "_" + else concat $ intersperse "," (map (\(f,a) -> show f ++ "." ++ show a) @pattern.patternAttributes) + loc.traceDescr = (maybe "" (\nm -> show nm ++ ":") @mbNamed) ++ show @nt ++ " :: " ++ show @con ++ " :: " ++ @loc.patDescr + + loc.addTrace = \v -> if @lhs.o_traces + then Trace @loc.traceDescr v + else v + loc.costCentreDescr = show @nt ++ ":" ++ show @con ++ ":" ++ @loc.patDescr + loc.addCostCentre = \v -> if @lhs.o_costcentre + then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v + else v + loc.addLinePragma = \v -> let p = getPos @name + hasPos = line p > 0 && column p >= 0 && not (null (file p)) + in if @lhs.o_linePragmas && hasPos + then PragmaExpr True True ("LINE " ++ show (line p) ++ " " ++ show (file p)) + $ LineExpr + $ v + else v + loc.decls = if @hasCode + then @originComment ( mkDecl (@lhs.o_monadic && @explicit) (Pattern3 @pattern.copy) (@loc.addTrace $ @loc.addCostCentre $ @loc.addLinePragma $ (TextExpr @rhs)) + (Set.fromList [attrname @lhs.options False fld nm | (fld,nm,_) <- Map.elems @defines]) + (Set.fromList [attrname @lhs.options True fld nm | (fld,nm) <- Set.toList @uses]) + : @loc.instDecls) + else @loc.instDecls + | CChildVisit loc.costCentreDescr = show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @name ++ ":" ++ show @nt ++ ":" ++ show @nr + loc.addCostCentre = \v -> if @lhs.o_costcentre + then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v + else v + loc.decls = let lhsVars = map (attrname @lhs.options True @name) (Map.keys @syn) + ++ if @isLast then [] else [unwrap ++ funname @name (@nr+1)] + rhsVars = map (attrname @lhs.options False @name) (Map.keys @inh) + unwrap = if @lhs.o_newtypes then typeName @nt (@nr + 1) ++ " " else "" + tuple | isMerging = TupleLhs [locname @lhs.options @name ++ "_comp"] + | otherwise = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars + rhs = @loc.addCostCentre $ Code.InvokeExpr (typeName @nt @nr) (SimpleExpr fun) (map SimpleExpr rhsVars) + isVirtual _ [] = False + isVirtual nm ((n,_,kind) : r) + | nm == n = case kind of + ChildAttr -> True + ChildReplace _ -> True + _ -> False + | otherwise = isVirtual nm r + isMerged = @name `Map.member` @lhs.mergeMap + isMerging = @name `elem` concatMap (\(_,cs) -> cs) (Map.elems @lhs.mergeMap) + merges = [ (c,cs) | (c,(_,cs)) <- Map.assocs @lhs.mergeMap, all (`Set.member` @loc.visitedSet) cs, @name `elem` (c:cs) ] + + baseNm = if @nr == 0 && isVirtual @name @lhs.children + then Ident (getName @name ++ "_inst") (getPos @name) + else @name + fun | @nr == 0 && Set.member @name @lhs.aroundMap + = locname @lhs.options @name ++ "_around " ++ funname baseNm 0 + | otherwise = funname baseNm @nr + outDecls | isMerged = [] -- merged variant is only produced after the last visit of the merged children + | otherwise = -- [mkDecl @lhs.o_monadic tuple rhs (Set.fromList lhsVars) (Set.fromList (funname baseNm @nr : rhsVars))] + if isMerging + then [mkDecl @lhs.o_monadic tuple rhs Set.empty Set.empty] + else [Resume @lhs.o_monadic (typeName @nt @nr) tuple rhs] + outMerged | null merges || @nr /= 0 = [] -- no merged child to produce + | otherwise = let (c,cs) = head merges + tuple' = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars' + lhsVars' = map (attrname @lhs.options True c) (Map.keys @syn) + ++ if @isLast then [] else [unwrap ++ funname c (@nr+1)] + rhsVars' = [ locname @lhs.options c' ++ "_comp" | c' <- cs ] + fun' = locname @lhs.options c ++ "_merge" + rhs' = App fun' (map SimpleExpr rhsVars') + in [Resume @lhs.o_monadic (typeName @nt @nr) tuple' rhs'] + in -- trace (show @name ++ " # " ++ show @loc.visitedSet ++ " # " ++ show (Map.assocs @lhs.mergeMap) ++ " # " ++ show merges ++ " # " ++ show @nr ++ " # " ++ show (length outMerged)) $ + (outDecls ++ outMerged) + +{ +mkDecl :: Bool -> Lhs -> Expr -> Set String -> Set String -> Decl +mkDecl True lhs rhs _ _ = Bind lhs rhs +mkDecl False lhs rhs s1 s2 = Decl lhs rhs s1 s2 + +unwrapSem :: Bool -> NontermIdent -> Expr -> Expr +unwrapSem False _ e = e +unwrapSem True nm e = Case e alts + where alts = [CaseAlt left right] + left = Fun (typeName nm 0) [SimpleExpr "x"] + right = SimpleExpr "x" +} + +ATTR Sequence CRule [ children : {[(Identifier,Type,ChildKind)]} ||] + +ATTR Sequence CRule Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ] +SEM Pattern + | Alias lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts + +SEM CRule + | CRule loc.definedInsts = if @isIn then [] else @pattern.definedInsts + +ATTR Pattern Patterns [ | | patternAttributes USE {++} {[]} : {[(Identifier, Identifier)]} ] +SEM Pattern + | Alias + lhs.patternAttributes = (@field,@attr) : @pat.patternAttributes + +------------------------------------------------------------------------------- +-- Numbering the visits +------------------------------------------------------------------------------- + +ATTR CVisits CVisit Sequence CRule + CSegments CSegment [ nr : Int | | ] +SEM CProduction + | CProduction visits.nr = 0 +SEM CVisits + | Cons tl.nr = @lhs.nr + 1 +SEM CInterface + | CInterface seg.nr = 0 +SEM CSegments + | Cons tl.nr = @lhs.nr + 1 + +------------------------------------------------------------------------------- +-- Checking last visit +------------------------------------------------------------------------------- + +ATTR CVisit CSegment [ isLast : Bool | | ] +ATTR CVisits CSegments [ | | isNil : Bool ] +SEM CVisits + | Cons lhs.isNil = False + hd.isLast = @tl.isNil + | Nil lhs.isNil = True +SEM CSegments + | Cons lhs.isNil = False + hd.isLast = @tl.isNil + | Nil lhs.isNil = True + +------------------------------------------------------------------------------- +-- Getting the next intra-visit dependencies +------------------------------------------------------------------------------- + +ATTR CVisit [ nextIntra : {Exprs} nextIntraVars : {Set String} | | ] +ATTR CVisits CVisit [ | | intra : {Exprs} intraVars : {Set String} ] +SEM CVisit + | CVisit lhs.intra = @intra.exprs + lhs.intraVars = @intra.usedVars +SEM CVisits + | Cons hd.nextIntra = @tl.intra + hd.nextIntraVars = @tl.intraVars + lhs.intra = @hd.intra + lhs.intraVars = @hd.intraVars + | Nil lhs.intra = [] + lhs.intraVars = Set.empty + +------------------------------------------------------------------------------- +-- Superfluous intra-visit dependencies due to higher-order children +-- (higher-order children can only be passed from their moment of creation) +------------------------------------------------------------------------------- + +SEM CRule + | CChildVisit + loc.isSuperfluousHigherOrderIntra + = @lhs.nr <= Map.findWithDefault (-1) @name @lhs.instVisitNrs + +------------------------------------------------------------------------------- +-- Intra-visit dependencies are expressions that need to be passed +------------------------------------------------------------------------------- + +ATTR Sequence CRule [ | | exprs USE {++} {[]} : {Exprs} ] +SEM CRule + | CRule loc.rulename = if @field == _LOC && @name `elem` @lhs.terminals + then funname @name 0 + else attrname @lhs.options @isIn @field @name + lhs.exprs = [SimpleExpr @loc.rulename] + | CChildVisit + loc.names = -- do not pass inst-childs as parameter if they are not defined yet + if @loc.isSuperfluousHigherOrderIntra + then [] + else [funname @name (@nr+1)] + lhs.exprs = let wrap = if @lhs.o_newtypes then \x -> App (typeName @nt (@nr + 1)) [x] else id + + addType expr | null @loc.instParams = expr + | otherwise = TypedExpr expr (@lhs.unfoldSemDom @nt (@nr+1) @loc.instParams) + + in map (wrap . addType . SimpleExpr) @loc.names + +ATTR Sequence CRule [ | | usedVars USE {`Set.union`} {Set.empty} : {Set String} ] +SEM CRule + | CRule + lhs.usedVars = Set.singleton @loc.rulename + | CChildVisit + lhs.usedVars = Set.fromList @loc.names + +------------------------------------------------------------------------------- +-- Type signatures are added to the declarations. +------------------------------------------------------------------------------- + +ATTR Sequence CRule [ | | tSigs USE {++} {[]} : {[Decl]} ] +SEM CRule + | CRule loc.mkTp = typeToCodeType (Just @lhs.nt) @loc.orgParams + lhs.tSigs = [ TSig (attrname @lhs.options False field attr) tp' + | (field,attr,tp) <- Map.elems @defines, isJust tp + , let tp1 = @loc.evalTp field $ @mkTp (fromJust tp) + tp' = case findOrigType attr @lhs.children of + Just tp' -> let tp'' = case tp' of + NT n params b -> NT (Ident ("T_" ++ show n) (getPos n)) params b + _ -> tp' + tp2 = @loc.evalTp field $ @mkTp tp'' + in Arr tp2 tp1 + Nothing -> tp1 + findOrigType _ [] = Nothing + findOrigType nm ((n,_,kind) : r) + | nm == n = case kind of + ChildReplace orig -> Just orig + _ -> Nothing + | otherwise = findOrigType nm r + ] + + loc.orgParams = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap + loc.evalTp = + \field tp -> let orgFldParams = map getName $ Map.findWithDefault [] childNt @lhs.paramMap + (childNt,instParams) = Map.findWithDefault (@lhs.nt,[]) field @lhs.paramInstMap + replMap = Map.fromList (zip orgFldParams instParams) + replace k = Map.findWithDefault ('@':k) k replMap + in if null instParams + then if null @orgParams + then tp + else idEvalType @lhs.options tp + else evalType @lhs.options replace tp + + | CChildVisit loc.mkTp = @loc.evalTp . typeToCodeType (Just @nt) @loc.orgParams + loc.definedTps = [ TSig (attrname @lhs.options True @name a) (@mkTp tp) | (a,tp) <- Map.toList @syn ] + loc.nextTp = typeName @nt (@nr+1) + lhs.tSigs = (if @isLast then id else (TSig (funname @name (@nr+1)) (TypeApp (SimpleType @nextTp) (map SimpleType @loc.instParams)) :)) @definedTps + + loc.orgParams = map getName $ Map.findWithDefault [] @nt @lhs.paramMap + loc.instParams = snd $ Map.findWithDefault (@nt,[]) @name @lhs.paramInstMap + loc.replParamMap = Map.fromList (zip @loc.orgParams @loc.instParams) + loc.replace = \k -> Map.findWithDefault k k @loc.replParamMap + loc.evalTp = if null @loc.orgParams then id else evalType @lhs.options @loc.replace + + +------------------------------------------------------------------------------- +-- Types of intra-visit dependencies are needed in the type of the +-- semantic function. +------------------------------------------------------------------------------- + +ATTR CVisits CVisit [ children : {[(Identifier,Type, ChildKind)]} | | ] +SEM CProduction + | CProduction visits.children = @children + + +ATTR Sequence CRule [ | | tps USE {++} {[]} : {[Type]} + allTpsFound USE {&&} {True} : Bool ] +SEM CRule + | CRule lhs.(tps,allTpsFound) = maybe ([],False) (\tp -> ([tp],True)) @tp + | CChildVisit lhs.tps = if @loc.isSuperfluousHigherOrderIntra + then [] + else [NT (ntOfVisit @nt (@nr+1)) @loc.instParams False] + +------------------------------------------------------------------------------- +-- Each visit has its semantic function +------------------------------------------------------------------------------- + +ATTR CVisits [ | | decls : {Decls} ] +ATTR CVisit [ | decls : {Decls} | ] +SEM CVisits + | Nil lhs.decls = [] + | Cons lhs.decls = @hd.decls + hd.decls = @tl.decls + +-- Note: lhs.decls are the decls related to the next visit function. We pass it +-- chained from right to left in order to build the next visit function inside +-- the previous one. +-- Note: intra decls are ignored. The intra-visit variables are not passed on +-- explicitly, but handled automatically due to nesting level. + +SEM CVisit + | CVisit (loc.higherOrderChildren,loc.firstOrderChildren) = partition (\(_,_,virt) -> isHigherOrder virt) @lhs.children + loc.firstOrderOrig = map pickOrigType @loc.firstOrderChildren + loc.funcname = seqSemname @lhs.prefix @lhs.nt @lhs.con @lhs.nr + loc.nextVisitName = if @lhs.isLast then [] else [visitname @lhs.prefix @lhs.nt (@lhs.nr+1)] + loc.nextVisitDecl = let lhs = TupleLhs @nextVisitName + -- rhs = App fun @lhs.nextIntra + rhs = Let @lhs.decls (SimpleExpr fun) + fun = seqSemname @lhs.prefix @lhs.nt @lhs.con (@lhs.nr+1) + in if @lhs.isLast + then [] + else [Decl lhs rhs (Set.fromList @nextVisitName) @lhs.nextIntraVars] + loc.isOneVisit = @lhs.isLast && @lhs.nr == 0 + loc.hasWrappers = @lhs.nt `Set.member` @lhs.wrappers + loc.refDecls = if @loc.isOneVisit && @loc.hasWrappers && reference @lhs.options + then let synAttrs = Map.toList @syn + synNT = "Syn" ++ "_" ++ getName @lhs.nt + synVars = [ SimpleExpr (attrname @lhs.options False _LHS a) | (a,_) <- synAttrs ] + rhs = App synNT synVars + lhs = Fun "___node" [] + in [Decl lhs rhs Set.empty Set.empty] + else [] + loc.decls = if @lhs.o_clean + then @vss.decls ++ @nextVisitDecl ++ @loc.refDecls -- Don't generate type signatures for Clean, they will cause the compiler to generate functions, even for constants + else @typeSigs ++ @vss.decls ++ @nextVisitDecl ++ @loc.refDecls + vss.lastExpr = mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh) $ map (SimpleExpr . lhsname @lhs.options False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName + intra.lastExpr = error "lastExpr: not used here" + loc.lastExprVars = map (lhsname @lhs.options False) (Map.keys @syn) ++ @loc.nextVisitName + (loc.blockFunDecls, loc.blockFirstFunCall) = mkPartitionedFunction @loc.funcname @loc.o_case @loc.nextVisitDecl @loc.lastExprVars @vss.blockDecls + + loc.costCentreDescr = "b" ++ ":" ++ show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @lhs.nr + loc.addCostCentre = \v -> if @lhs.o_costcentre + then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v + else v + + loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap + loc.semFun = let lhs = Fun @funcname lhs_args + lhs_args = if @lhs.nr == 0 then map field @loc.firstOrderOrig else [] -- @intra.exprs + + field (name,NT tp tps _,_) = let unwrap | @lhs.o_newtypes = \x -> App (sdtype tp) [x] + | otherwise = id + + addType expr | null tps = expr + | otherwise = TypedExpr expr (@lhs.unfoldSemDom tp 0 tps) + + in unwrap $ addType $ SimpleExpr $ funname name 0 + field (name,tp,_) = let expr = SimpleExpr (funname name 0) + in if null @loc.params + then expr + else TypedExpr expr (idEvalType @lhs.options $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp) + + mbEvalTp | null @loc.params = const Nothing + | otherwise = Just . (idEvalType @lhs.options) + + rhs = wrap + . mkSemFun @lhs.nt @lhs.nr [mkLambdaArg (lhsname @lhs.options True nm) (mbEvalTp $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp) | (nm,tp) <- Map.assocs @inh] + $ @loc.addCostCentre + $ if @ordered && @loc.o_splitsems + then @loc.blockFirstFunCall + else mkDecls @loc.declsType @decls + . ResultExpr (typeName @lhs.nt @lhs.nr) + . mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh) + $ map (SimpleExpr . lhsname @lhs.options False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName + wrap = if @lhs.o_newtypes + then \x -> App (typeName @lhs.nt @lhs.nr) [x] + else id + in Decl lhs rhs Set.empty Set.empty + loc.tsig = TSig @funcname @semType + loc.semType = let argType (NT tp tps _) r | tp /= _SELF = typeAppStrs (sdtype tp) tps `Arr` r + | tp == _SELF = error "GenerateCode: found an intra-type with type SELF, which should have been prevented by CRule.tps" + argType (Haskell tp) r = SimpleType tp `Arr` r + argType _ _ = error "Self type not allowed here" + evalTp | null @loc.params = id + | otherwise = idEvalType @lhs.options + + in appQuant @lhs.quantMap @lhs.nt $ appContext @lhs.contextMap @lhs.nt $ evalTp $ + if @lhs.nr == 0 + then foldr argType (typeAppStrs (sdtype @lhs.nt ) @loc.params) (map (\(_,t,_) -> t) @loc.firstOrderOrig) + else foldr argType (typeAppStrs (typeName @lhs.nt @lhs.nr) @loc.params) [] -- @intra.tps + lhs.decls = ( if @lhs.with_sig + then [@tsig, @semFun] + else [@semFun] + ) ++ + ( if @ordered && @loc.o_splitsems + then @loc.blockFunDecls + else [] + ) + loc.typeSigs = if @lhs.o_sig && not @o_case + then @vss.tSigs + else [] + loc.o_do = @ordered && @lhs.o_monadic + loc.o_case = not @loc.o_do && @lhs.o_case && @ordered && not (hasPragma @lhs.allPragmas @lhs.nt @lhs.con _NOCASE) + loc.declsType = if @loc.o_do + then DeclsDo + else if @loc.o_case + then DeclsCase + else DeclsLet + loc.o_splitsems = @ordered && @lhs.o_splitsems + +{ +mkLambdaArg :: String -> Maybe Code.Type -> Expr +mkLambdaArg nm Nothing = SimpleExpr nm +mkLambdaArg nm (Just tp) = TypedExpr (SimpleExpr nm) tp + +mkLambda :: Exprs -> Expr -> Expr +mkLambda [] e = e +mkLambda xs e = Lambda xs e + +mkSemFun :: Identifier -> Int -> Exprs -> Expr -> Expr +mkSemFun nt nr xs e = SemFun (typeName nt nr) xs e + +typeAppStrs :: String -> [String] -> Code.Type +typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params) + +isHigherOrder :: ChildKind -> Bool +isHigherOrder ChildAttr = True +isHigherOrder _ = False + +pickOrigType :: (Identifier, Type, ChildKind) -> (Identifier, Type, ChildKind) +pickOrigType (nm, _, virt@(ChildReplace x)) = (nm, x, virt) +pickOrigType x = x +} + +ATTR CVisits CVisit Sequence CRule [ instVisitNrs : {Map Identifier Int} || ] +ATTR CVisits CVisit [|| gatherInstVisitNrs USE {`Map.union`} {Map.empty} : {Map Identifier Int} ] +SEM CProduction + | CProduction + visits.instVisitNrs = @visits.gatherInstVisitNrs + +SEM CVisit + | CVisit + lhs.gatherInstVisitNrs = Map.fromList [(i,@lhs.nr) | i <- @vss.definedInsts] + +------------------------------------------------------------------------------- +-- Push aroundsMap downward +------------------------------------------------------------------------------- + +ATTR CNonterminals CNonterminal + [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Set Identifier))} || ] + +ATTR CProductions CProduction + [ aroundMap : {Map ConstructorIdent (Set Identifier)} || ] + +ATTR CVisits CVisit Sequence CRule [ aroundMap : {Set Identifier} | | ] + +SEM CGrammar | CGrammar loc.aroundMap = @aroundsMap +SEM CNonterminal | CNonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap +SEM CProduction | CProduction loc.aroundMap = Map.findWithDefault Set.empty @con @lhs.aroundMap + +------------------------------------------------------------------------------- +-- Push mergeMap downward +------------------------------------------------------------------------------- + +ATTR CNonterminals CNonterminal + [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))} || ] + +ATTR CProductions CProduction + [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))} || ] + +ATTR CVisits CVisit Sequence CRule [ mergeMap : {Map Identifier (Identifier, [Identifier])} | | ] + +SEM CGrammar | CGrammar loc.mergeMap = @mergeMap +SEM CNonterminal | CNonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap +SEM CProduction | CProduction loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap + +------------------------------------------------------------------------------- +-- Generate a partitioned version of the sequence of rules +------------------------------------------------------------------------------- + +ATTR Sequence [ lastExpr : Expr | | blockDecls : DeclBlocks ] + +ATTR Sequence CRule [ | declsAbove : {[Decl]} | ] +SEM CVisit + | CVisit + vss.declsAbove = [] + intra.declsAbove = error "declsAbove: not used here" + +SEM CRule + | CRule + lhs.declsAbove = @lhs.declsAbove ++ @loc.decls + | CChildVisit + lhs.declsAbove = [] + +SEM Sequence + | Cons + lhs.blockDecls = @hd.bldBlocksFun @tl.blockDecls + | Nil + lhs.blockDecls = DeclTerminator @lhs.declsAbove @lhs.lastExpr + +ATTR CRule [ | | bldBlocksFun : {DeclBlocks -> DeclBlocks} ] +SEM CRule + | CRule + lhs.bldBlocksFun = id + | CChildVisit + lhs.bldBlocksFun = DeclBlock @lhs.declsAbove (head @loc.decls) + +{ +mkPartitionedFunction :: String -> Bool -> [Decl] -> [String] -> DeclBlocks -> ([Decl], Expr) +mkPartitionedFunction prefix' optCase nextVisitDecls lastExprVars cpsTree + = let inh = Inh_DeclBlocksRoot { prefix_Inh_DeclBlocksRoot = prefix' + , optCase_Inh_DeclBlocksRoot = optCase + , nextVisitDecls_Inh_DeclBlocksRoot = nextVisitDecls + , lastExprVars_Inh_DeclBlocksRoot = lastExprVars + } + sem = sem_DeclBlocksRoot (DeclBlocksRoot cpsTree) + syn = wrap_DeclBlocksRoot sem inh + in (lambdas_Syn_DeclBlocksRoot syn, firstCall_Syn_DeclBlocksRoot syn) +} + +WRAPPER DeclBlocksRoot + +ATTR DeclBlocksRoot DeclBlocks [ prefix : String optCase : Bool nextVisitDecls : {[Decl]} lastExprVars : {[String]} | | ] +ATTR DeclBlocksRoot [ | | lambdas : {[Decl]} firstCall : Expr ] + +SEM DeclBlocksRoot + | DeclBlocksRoot + lhs.lambdas = @blocks.decls + lhs.firstCall = @blocks.callExpr + +ATTR DeclBlocks [ blockNr : Int | | ] +SEM DeclBlocksRoot + | DeclBlocksRoot + blocks.blockNr = 1 +SEM DeclBlocks + | DeclBlock + next.blockNr = @lhs.blockNr + 1 + +ATTR DeclBlocks [ | | callExpr : Expr freeVars : {[String]} ] +SEM DeclBlocks + | DeclBlock DeclTerminator + loc.lambdaName = @lhs.prefix ++ "_block" ++ show @lhs.blockNr + loc.pragmaDecl = PragmaDecl ("NOINLINE " ++ @loc.lambdaName) + lhs.callExpr = App @loc.lambdaName (map SimpleExpr @loc.freeVars) + | DeclTerminator + loc.freeVars = freevars @lhs.lastExprVars (@defs ++ @lhs.nextVisitDecls) + | DeclBlock + loc.freeVars = freevars @next.freeVars (@visit : @defs) + +ATTR DeclBlocks [ | | decls : {[Decl]} ] +SEM DeclBlocks + | DeclTerminator + lhs.decls = [ mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ @lhs.nextVisitDecls) @result ] + | DeclBlock + loc.decl = mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ [@visit]) @next.callExpr + lhs.decls = (if @lhs.blockNr > 1 then [@loc.pragmaDecl] else []) ++ [@loc.decl] ++ @next.decls + +{ +freevars :: [String] -> [Decl] -> [String] +freevars additional decls + = Set.toList (allused `Set.difference` alldefined) + where + allused = Set.unions (Set.fromList additional : map usedvars decls) + alldefined = Set.unions (map definedvars decls) + + usedvars (Decl _ _ _ uses) = uses + usedvars _ = Set.empty + + definedvars (Decl _ _ defs _) = defs + definedvars _ = Set.empty + +mkBlockLambda :: Bool -> String -> [String] -> [Decl] -> Expr -> Decl +mkBlockLambda optCase name args decls expr + = Decl lhs rhs Set.empty Set.empty + where + lhs = Fun name (map SimpleExpr args) + rhs = mkLet optCase decls expr +} + + +------------------------------------------------------------------------------- +-- The semantic domain is generated from the interface. +------------------------------------------------------------------------------- + +ATTR CInterface CSegments CSegment [ | | semDom USE {++} {[]} : {[Decl]} ] +SEM CInterface + | CInterface lhs.semDom = Comment "semantic domain" : @seg.semDom + +SEM CSegment + | CSegment loc.altSemForm = breadthFirst @lhs.options + loc.tp = if @loc.altSemForm + then TypeApp (SimpleType "Child") [SimpleType "EvalInfo", @loc.indexExpr ] + else foldr Arr @loc.synTps @loc.inhTps + loc.inhTps = [typeToCodeType (Just @lhs.nt) @loc.params tp | tp <- Map.elems @inh] + loc.inhTup = mkTupleType @lhs.o_unbox (null @loc.inhTps) @loc.inhTps + loc.synTps = mkTupleType @lhs.o_unbox (null @loc.inhTps) ([typeToCodeType (Just @lhs.nt) @loc.params tp | tp <- Map.elems @syn] ++ @loc.continuation) + loc.curTypeName = typeName @lhs.nt @lhs.nr + loc.nextTypeName = typeName @lhs.nt (@lhs.nr + 1) + loc.indexName = "I_" ++ @loc.curTypeName + loc.dataIndex = Code.Data @loc.indexName @loc.params [DataAlt @loc.indexName []] False [] + loc.indexExpr = TypeApp (SimpleType @loc.indexName) (map (SimpleType . ('@':)) @loc.params) + loc.indexStr = "(" ++ @loc.indexName ++ concatMap (\p -> " " ++ p) @loc.params ++ ")" + loc.inhInstance = Code.Data "instance Inh" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Inh") [@loc.inhTup] ] False [] + loc.synInstance = Code.Data "instance Syn" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Syn") [@loc.synTps] ] False [] + loc.continuation = if @lhs.isLast + then [] + else [TypeApp (SimpleType @loc.nextTypeName) (map (SimpleType . ('@':)) @loc.params)] + loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap + lhs.semDom = let name = typeName @lhs.nt @lhs.nr + evalTp | null @loc.params = id + | otherwise = idEvalType @lhs.options + in ( if @lhs.o_newtypes + then [ Code.NewType name @loc.params name (evalTp @loc.tp) ] + else [ Code.Type name @loc.params (evalTp @loc.tp) ] ) + ++ ( if @loc.altSemForm + then [@loc.dataIndex, @loc.inhInstance, @loc.synInstance] + else [] ) + +ATTR CNonterminals CNonterminal CInterface CSegments CSegment [ | | semDomUnfoldGath USE {`Map.union`} {Map.empty} : {Map (NontermIdent, Int) ([String], Code.Type)} ] + +SEM CSegment + | CSegment + lhs.semDomUnfoldGath = Map.singleton (@lhs.nt, @lhs.nr) (@loc.params, @loc.tp) + +ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ unfoldSemDom : {NontermIdent -> Int -> [String] -> Code.Type} | | ] + +SEM CGrammar + | CGrammar + loc.unfoldSemDom = + \nt nr repl -> + let (params, tp) = Map.findWithDefault (error ("No such semantic domain: " ++ show nt)) (nt, nr) @nonts.semDomUnfoldGath + replMap = Map.fromList (zip params repl) + replace k = Map.findWithDefault ('@':k) k replMap + in evalType @lhs.options replace tp + +{ +typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type +typeToCodeType _ _ tp + = case tp of + NT nt tps defor -> NontermType (getName nt) tps defor + Haskell t -> SimpleType t + Self -> error "Self type not allowed here." + +evalType :: Options -> (String -> String) -> Code.Type -> Code.Type +evalType opts replf t' + = chase t' + where + chase t + = case t of + Arr l r -> Arr (chase l) (chase r) + TypeApp f as -> TypeApp (chase f) (map chase as) + TupleType tps -> TupleType (map chase tps) + UnboxedTupleType tps -> UnboxedTupleType (map chase tps) + Code.List tp -> Code.List (chase tp) + SimpleType txt -> let tks = lexTokens opts (initPos txt) txt + tks' = map replaceTok tks + txt' = unlines . showTokens . tokensToStrings $ tks' + in SimpleType txt' + TMaybe m -> TMaybe (chase m) + TEither l r -> TEither (chase l) (chase r) + TMap k v -> TMap (chase k) (chase v) + TIntMap v -> TIntMap (chase v) + TSet m -> TSet (chase m) + _ -> t + + replaceTok t + = case t of + AGLocal v p _ -> HsToken (replf $ getName v) p + _ -> t + +idEvalType :: Options -> Code.Type -> Code.Type +idEvalType options = evalType options id +} + +------------------------------------------------------------------------------- +-- Wrapper functions +------------------------------------------------------------------------------- + +SEM CNonterminal + | CNonterminal loc.semWrapper = let params' = map getName @params + inhAttrs = Map.toList @inh + synAttrs = Map.toList @syn + inhVars = [ SimpleExpr (attrname @lhs.options True _LHS a) | (a,_) <- inhAttrs ] + synVars = [ SimpleExpr (attrname @lhs.options False _LHS a) | (a,_) <- synAttrs ] + var = "sem" + wrapNT = "wrap" ++ "_" ++ getName @nt + inhNT = "Inh" ++ "_" ++ getName @nt + synNT = "Syn" ++ "_" ++ getName @nt + varPat = if @lhs.o_newtypes + then App (sdtype @nt) [SimpleExpr var] + else SimpleExpr var + + evalTp | null params' = id + | otherwise = idEvalType @lhs.options + appParams nm = TypeApp (SimpleType nm) (map SimpleType params') + typeSig = TSig wrapNT (evalTp $ appParams (sdtype @nt) `Arr` (appParams inhNT `Arr` appParams synNT)) + mkstrict = Named @lhs.o_strictwrap + mkdata n attrs = Data n params' [Record n [mkstrict (getName f++"_"++n) $ evalTp $ typeToCodeType (Just @nt) params' t | (f,t) <- attrs]] False [] + datas = [mkdata inhNT inhAttrs, mkdata synNT synAttrs] + in datas ++ [ typeSig + , Decl (Fun wrapNT [varPat, App inhNT inhVars]) + (Let @inter.wrapDecls (App synNT synVars)) + Set.empty Set.empty + ] + +ATTR CInterface CSegments CSegment [ | | wrapDecls USE {++} {[]}: {Decls} ] +SEM CSegment + | CSegment lhs.wrapDecls = let lhsVars = map (lhsname @lhs.options False) (Map.keys @syn) + ++ if @lhs.isLast then [] else [unwrap ++ sem (@lhs.nr+1)] + rhsVars = map (lhsname @lhs.options True) (Map.keys @inh) + rhs = map SimpleExpr rhsVars + unwrap = if @lhs.o_newtypes then typeName @lhs.nt (@lhs.nr + 1) ++ " " else "" + var = "sem" + sem 0 = var + sem n = var ++ "_" ++ show n + ntt = typeName @lhs.nt @lhs.nr + in [ EvalDecl ntt (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (InvokeExpr ntt (SimpleExpr $ sem @lhs.nr) rhs) ] + -- [ Decl (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (App (sem @lhs.nr) rhs) (Set.fromList lhsVars) (Set.fromList rhsVars) ] + +------------------------------------------------------------------------------- +-- Errors for missing type signatures. It's an error when one of the +-- attributes in the intra-visit dependencies does not have a type. +-- UPDATE: it is not an error anymore... +------------------------------------------------------------------------------- + +ATTR CNonterminals CNonterminal + CProductions CProduction + CVisits CVisit [ with_sig : Bool | | ] + +SEM CGrammar + | CGrammar nonts.with_sig = typeSigs @lhs.options + +SEM CGrammar [ | | errors : {Seq Error} ] + | CGrammar lhs.errors = Seq.empty + +------------------------------------------------------------------------------- +-- Provide a description of the interfaces as comments +------------------------------------------------------------------------------- + +SEM CNonterminal + | CNonterminal loc.comment = Comment . unlines . map ind $ ( @inter.comments ++ ("alternatives:" : map ind @prods.comments) ) + +ATTR CInterface CSegments CSegment + CProductions CProduction + CVisits CVisit Sequence CRule [ | | comments USE {++} {[]}: {[String]} ] + +ATTR Sequence CRule [ what:String | | ] + +SEM CSegment + | CSegment lhs.comments = let body = map ind (showsSegment (CSegment @inh @syn)) + in if null body + then [] + else ("visit " ++ show @lhs.nr ++ ":") : body + +SEM CProduction + | CProduction loc.firstOrderChildren = [ (nm,fromJust mb,virt) | (nm,tp,virt) <- @children, let mb = isFirstOrder virt tp, isJust mb ] + lhs.comments = ("alternative " ++ getName @con ++ ":") + : map ind ( map (\(x,y,_) -> makeLocalComment 14 "child" x (Just y)) @loc.firstOrderChildren + ++ @visits.comments + ) + +{ +-- for a virtual child that already existed as a child, returns +isFirstOrder :: ChildKind -> Type -> Maybe Type +isFirstOrder ChildSyntax tp = Just tp +isFirstOrder ChildAttr _ = Nothing +isFirstOrder (ChildReplace tp) _ = Just tp +} + +SEM CVisit + | CVisit lhs.comments = let body = map ind (@vss.comments ++ @intra.comments) + in if null body + then [] + else ("visit " ++ show @lhs.nr ++ ":") : body + vss.what = "local" + intra.what = "intra" + + +SEM CRule + | CRule lhs.comments = [ makeLocalComment 11 @lhs.what name tp | (field,name,tp) <- Map.elems @defines, field == _LOC ] + ++ [ makeLocalComment 11 "inst " name tp | (field,name,tp) <- Map.elems @defines, field == _INST ] + +{ +makeLocalComment :: Int -> String -> Identifier -> Maybe Type -> String +makeLocalComment width what name tp = let x = getName name + y = maybe "_" (\t -> case t of + (NT nt tps _) -> getName nt ++ " " ++ unwords tps + Haskell t' -> '{' : t' ++ "}" + Self -> error "Self type not allowed here.") tp + in ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y ) + +} + +------------------------------------------------------------------------------- +-- And tie it all together +------------------------------------------------------------------------------- + +ATTR CNonterminals CNonterminal [ | | chunks USE {++} {[]} : {Chunks} ] +ATTR CProductions CProduction [ | | decls USE {++} {[]} : {Decls} ] +ATTR CGrammar [ | | output : Program ] + +SEM CGrammar + | CGrammar lhs.output = Program @nonts.chunks @multivisit + +SEM CNonterminal + | CNonterminal lhs.chunks = [ Chunk (getName @nt) + (Comment (getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')) + (if @lhs.o_pretty then [@loc.comment] else []) + (if isJust @lhs.o_data then [@loc.dataDef] else []) + (if @lhs.o_cata && @loc.genCata then @loc.cataFun else []) + (if @lhs.o_sig then @inter.semDom else []) + (if @nt `Set.member` @lhs.wrappers then @loc.semWrapper else []) + (if @lhs.o_sem then @prods.decls else []) + (if @lhs.o_sem then @prods.semNames else []) + ] + +{ +-- Lets or nested Cases? +-- or even a do-expression? + +data DeclsType = DeclsLet | DeclsCase | DeclsDo + +mkDecls :: DeclsType -> Decls -> Expr -> Expr +mkDecls DeclsLet = mkLet False +mkDecls DeclsCase = mkLet True +mkDecls DeclsDo = \decls -> Do (map toBind decls) + where toBind (Decl lhs rhs _ _) = BindLet lhs rhs + toBind d = d + +mkLet :: Bool -> Decls -> Expr -> Expr +mkLet False decls body = Let decls body +mkLet True decls body = foldr oneCase body decls + +oneCase :: Decl -> Expr -> Expr +oneCase (Decl left rhs _ _) ex = Case rhs [CaseAlt left ex] +oneCase (Resume _ nt left rhs) ex = ResumeExpr nt rhs left ex +oneCase _ ex = ex + +-- Gives the name of the visit function +funname :: Show a => a -> Int -> String +funname field 0 = show field ++ "_" +funname field nr = show field ++ "_" ++ show nr + +-- Gives the name of a semantic function +seqSemname :: String -> NontermIdent -> ConstructorIdent -> Int -> String +seqSemname pre nt con 0 = semname pre nt con +seqSemname pre nt con nr = semname pre nt con ++ "_" ++ show nr + +-- Gives the name of a type +typeName :: NontermIdent -> Int -> String +typeName nt 0 = "T_" ++ show nt +typeName nt n = "T_" ++ show nt ++ "_" ++ show n + +ntOfVisit :: NontermIdent -> Int -> NontermIdent +ntOfVisit nt 0 = nt +ntOfVisit nt n = Ident (show nt ++ "_" ++ show n) (getPos nt) + +-- Gives the name of a visit function +visitname :: String -> NontermIdent -> Int -> String +visitname pre nt n = pre ++ getName nt ++ "_" ++ show n +} + +------------------------------------------------------------------------------- +-- Datatypes were already present +------------------------------------------------------------------------------- + +ATTR CNonterminals CNonterminal [ derivings: {Derivings} typeSyns : {TypeSyns} | | ] +ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ wrappers:{Set NontermIdent} | | ] + +SEM CGrammar + | CGrammar nonts . typeSyns = @typeSyns + . derivings = @derivings + . wrappers = @wrappers + +SEM CNonterminal + | CNonterminal loc.dataDef = let params' = map getName @params + typeSyn tp = let theType = + case tp of + CommonTypes.Maybe t -> TMaybe $ typeToCodeType (Just @nt) params' t + CommonTypes.Either t1 t2 -> TEither (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2) + CommonTypes.Map t1 t2 -> TMap (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2) + CommonTypes.IntMap t -> TIntMap $ typeToCodeType (Just @nt) params' t + CommonTypes.List t -> Code.List $ typeToCodeType (Just @nt) params' t + CommonTypes.Tuple ts -> Code.TupleType [typeToCodeType (Just @nt) params' t | (_,t) <- ts ] + CommonTypes.OrdSet t -> TSet $ typeToCodeType (Just @nt) params' t + CommonTypes.IntSet -> TIntSet + in Code.Type (getName @nt) params' (idEvalType @lhs.options theType) + derivings = maybe [] (map getName . Set.toList) (Map.lookup @nt @lhs.derivings) + dataDef = Data (getName @nt) (map getName @params) @prods.dataAlts (maybe False id @lhs.o_data) derivings + in maybe dataDef typeSyn $ lookup @nt @lhs.typeSyns + +ATTR CProductions [ | | dataAlts : {DataAlts} ] +ATTR CProduction [ | | dataAlt : {DataAlt} ] + +SEM CProductions + | Cons lhs.dataAlts = @hd.dataAlt : @tl.dataAlts + | Nil lhs.dataAlts = [] + +SEM CProduction + | CProduction loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap + lhs.dataAlt = let conNm = conname @lhs.o_rename @lhs.nt @con + mkFields :: (NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> a) -> [a] + mkFields f = map (\(nm,t,_) -> f @lhs.nt @con nm (typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested t)) @loc.firstOrderChildren + in if dataRecords @lhs.options + then Record conNm $ mkFields $ toNamedType (strictData @lhs.options) + else DataAlt conNm $ mkFields $ \_ _ _ t -> t + +{ +toNamedType :: Bool -> NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> Code.NamedType +toNamedType genStrict nt con nm tp + = Code.Named genStrict strNm tp + where strNm = recordFieldname nt con nm +} + +------------------------------------------------------------------------------- +-- Catamorphism were already present +------------------------------------------------------------------------------- + +SEM CNonterminal + | CNonterminal loc.genCata = not (@nt `Set.member` nocatas @lhs.options) + loc.cataFun = let appParams nm = TypeApp (SimpleType nm) (map SimpleType (map getName @params)) + evalTp | null @params = id + | otherwise = idEvalType @lhs.options + tSig = TSig (cataname @lhs.prefix @nt) + (appQuant @lhs.quantMap @nt $ appContext @lhs.contextMap @nt $ evalTp $ appParams (getName @nt) `Arr` appParams (sdtype @nt)) + special typ = case typ of + CommonTypes.List tp -> + let cons = SimpleExpr (semname @lhs.prefix @nt (identifier "Cons")) + nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" )) + arg = SimpleExpr "list" + rarg = case tp of + NT t _ _ -> let t' = maybe t id (deforestedNt t) + in SimpleExpr ("(Prelude.map " ++ (cataname @lhs.prefix t') ++ " list)") + _ -> arg + lhs = Fun (cataname @lhs.prefix @nt) [arg] + rhs = (App "Prelude.foldr" [cons,nil,rarg]) + in [Decl lhs rhs Set.empty Set.empty] + CommonTypes.Maybe tp -> + let just = semname @lhs.prefix @nt (identifier "Just") + nothing = semname @lhs.prefix @nt (identifier "Nothing" ) + arg = SimpleExpr "x" + rarg = case tp of + NT t _ _ -> let t' = maybe t id (deforestedNt t) + in App (cataname @lhs.prefix t') [arg] + _ -> arg + lhs a = Fun (cataname @lhs.prefix @nt) [a] + in [Decl (lhs (App "Prelude.Just" [arg])) (App just [rarg]) Set.empty Set.empty + ,Decl (lhs (SimpleExpr "Prelude.Nothing")) (SimpleExpr nothing) Set.empty Set.empty + ] + CommonTypes.Either tp1 tp2 -> + let left = semname @lhs.prefix @nt (identifier "Left") + right = semname @lhs.prefix @nt (identifier "Right" ) + arg = SimpleExpr "x" + rarg0 = case tp1 of + NT t _ _ -> let t' = maybe t id (deforestedNt t) + in App (cataname @lhs.prefix t') [arg] + _ -> arg + rarg1 = case tp2 of + NT t _ _ -> let t' = maybe t id (deforestedNt t) + in App (cataname @lhs.prefix t') [arg] + _ -> arg + lhs a = Fun (cataname @lhs.prefix @nt) [a] + in [Decl (lhs (App "Prelude.Left" [arg])) (App left [rarg0]) Set.empty Set.empty + ,Decl (lhs (App "Prelude.Right" [arg])) (App right [rarg1]) Set.empty Set.empty + ] + CommonTypes.Map _ tp -> + let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry")) + nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil")) + arg = SimpleExpr "m" + rarg = case tp of + NT t _ _ -> let t' = maybe t id (deforestedNt t) + in App "Data.Map.map" [SimpleExpr $ cataname @lhs.prefix t', arg] + _ -> arg + lhs = Fun (cataname @lhs.prefix @nt) [arg] + rhs = App "Data.Map.foldrWithKey" [entry,nil,rarg] + in [Decl lhs rhs Set.empty Set.empty] + CommonTypes.IntMap tp -> + let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry")) + nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil")) + arg = SimpleExpr "m" + rarg = case tp of + NT t _ _ -> let t' = maybe t id (deforestedNt t) + in App "Data.IntMap.map" [SimpleExpr $ cataname @lhs.prefix t', arg] + _ -> arg + lhs = Fun (cataname @lhs.prefix @nt) [arg] + rhs = App "Data.IntMap.foldWithKey" [entry,nil,rarg] + in [Decl lhs rhs Set.empty Set.empty] + CommonTypes.Tuple tps -> + let con = semname @lhs.prefix @nt (identifier "Tuple") + tps' = [ (SimpleExpr (getName x),y) | (x,y) <- tps] + rargs = map rarg tps' + rarg (n, tp) = case tp of + NT t _ _ -> let t' = maybe t id (deforestedNt t) + in App (cataname @lhs.prefix t') [n] + _ -> n + + lhs = Fun (cataname @lhs.prefix @nt) [TupleExpr (map fst tps')] + rhs = App con rargs + in [Decl lhs rhs Set.empty Set.empty] + CommonTypes.OrdSet tp -> + let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry")) + nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" )) + arg = SimpleExpr "set" + rentry = case tp of + NT t _ _ -> let t' = maybe t id (deforestedNt t) + in App "(.)" [entry, SimpleExpr $ cataname @lhs.prefix t'] + _ -> entry + lhs = Fun (cataname @lhs.prefix @nt) [arg] + rhs = (App "Data.Set.foldr" [rentry,nil,arg]) + in [Decl lhs rhs Set.empty Set.empty] + CommonTypes.IntSet -> + let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry")) + nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" )) + arg = SimpleExpr "set" + lhs = Fun (cataname @lhs.prefix @nt) [arg] + rhs = (App "Data.IntSet.foldr" [entry,nil,arg]) + in [Decl lhs rhs Set.empty Set.empty] + in Comment "cata" : + (if @lhs.o_sig then [tSig] else []) ++ + maybe @prods.cataAlts special (lookup @nt @lhs.typeSyns) + +ATTR CProductions [ | | cataAlts : {Decls} ] +ATTR CProduction [ | | cataAlt : {Decl} ] + + +SEM CProductions + | Cons lhs.cataAlts = @hd.cataAlt : @tl.cataAlts + | Nil lhs.cataAlts = [] + +SEM CProduction + | CProduction lhs.cataAlt = let lhs = Fun (cataname @lhs.prefix @lhs.nt) [lhs_pat] + lhs_pat = App (conname @lhs.o_rename @lhs.nt @con) + (map (\(n,_,_) -> SimpleExpr $ locname @lhs.options $ n) @loc.firstOrderChildren) + rhs = App (semname @lhs.prefix @lhs.nt @con) + (map argument @loc.firstOrderChildren) + argument (nm,NT tp _ _,_) = App (cataname @lhs.prefix tp) + [SimpleExpr (locname @lhs.options nm)] + argument (nm, _,_) = SimpleExpr (locname @lhs.options nm) + in Decl lhs rhs Set.empty Set.empty + + +------------------------------------------------------------------------------- +-- Collect names of generated stuff +------------------------------------------------------------------------------- + +ATTR CProductions CProduction CVisits CVisit [ | | semNames USE {++} {[]} : {[String]} ] + +{- +SEM CProduction + | CProduction + lhs.semNames = [cataname @lhs.prefix @lhs.nt] ++ @visits.semNames +-} + +SEM CVisit + | CVisit + lhs.semNames = [@loc.funcname] + diff --git a/src-ag/HsToken.ag b/src-ag/HsToken.ag --- a/src-ag/HsToken.ag +++ b/src-ag/HsToken.ag @@ -1,33 +1,33 @@ -imports -{ -import CommonTypes -import UU.Scanner.Position(Pos) -} - -DATA HsTokensRoot - | HsTokensRoot tokens : HsTokens - -TYPE HsTokens = [HsToken] - -DATA HsToken - | AGLocal var : {Identifier} -- either a local or a terminal - pos : {Pos} - rdesc : {Maybe String} -- description of the rule the local reference appears in - - | AGField field : {Identifier} -- Misnomer: this is actually a reference to an attribute, not a terminal! - attr : {Identifier} - pos : {Pos} - rdesc : {Maybe String} -- description of the rule the attribute reference appears in - - | HsToken value : {String} - pos : {Pos} - | CharToken value : {String} - pos : {Pos} - | StrToken value : {String} - pos : {Pos} - | Err mesg : {String} - pos : {Pos} - - - -DERIVING HsToken : Show +imports +{ +import CommonTypes +import UU.Scanner.Position(Pos) +} + +DATA HsTokensRoot + | HsTokensRoot tokens : HsTokens + +TYPE HsTokens = [HsToken] + +DATA HsToken + | AGLocal var : {Identifier} -- either a local or a terminal + pos : {Pos} + rdesc : {Maybe String} -- description of the rule the local reference appears in + + | AGField field : {Identifier} -- Misnomer: this is actually a reference to an attribute, not a terminal! + attr : {Identifier} + pos : {Pos} + rdesc : {Maybe String} -- description of the rule the attribute reference appears in + + | HsToken value : {String} + pos : {Pos} + | CharToken value : {String} + pos : {Pos} + | StrToken value : {String} + pos : {Pos} + | Err mesg : {String} + pos : {Pos} + + + +DERIVING HsToken : Show diff --git a/src-ag/Interfaces.ag b/src-ag/Interfaces.ag --- a/src-ag/Interfaces.ag +++ b/src-ag/Interfaces.ag @@ -1,16 +1,16 @@ -imports -{ -import CommonTypes -import SequentialTypes -} - -DATA IRoot | IRoot inters:Interfaces -TYPE Interfaces = [Interface] -DATA Interface | Interface nt:NontermIdent - cons:{[ConstructorIdent]} - seg:Segments -TYPE Segments = [Segment] -DATA Segment | Segment inh:{[Vertex]} - syn:{[Vertex]} - - +imports +{ +import CommonTypes +import SequentialTypes +} + +DATA IRoot | IRoot inters:Interfaces +TYPE Interfaces = [Interface] +DATA Interface | Interface nt:NontermIdent + cons:{[ConstructorIdent]} + seg:Segments +TYPE Segments = [Segment] +DATA Segment | Segment inh:{[Vertex]} + syn:{[Vertex]} + + diff --git a/src-ag/KWOrder.ag b/src-ag/KWOrder.ag --- a/src-ag/KWOrder.ag +++ b/src-ag/KWOrder.ag @@ -1,217 +1,217 @@ -INCLUDE "AbstractSyntax.ag" -INCLUDE "HsToken.ag" -INCLUDE "Expression.ag" -INCLUDE "Patterns.ag" -INCLUDE "DistChildAttr.ag" -INCLUDE "ExecutionPlanPre.ag" -INCLUDE "ExecutionPlanCommon.ag" - -imports -{ -import AbstractSyntax -import HsToken -import Expression -import Patterns -import Options -import PPUtil -import Pretty -import Knuth1 -import KennedyWarren -import ExecutionPlan -import Data.Maybe -import Debug.Trace -import Data.Set(Set) -import Data.Map(Map) -import Data.Sequence(Seq) -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import Data.Monoid(mappend,mempty) -} - -------------------------------------------------------------------------------- --- Dependency graph per production -------------------------------------------------------------------------------- --- Gather vertices -ATTR HsToken Expression - Rule Rules - Pattern Patterns - Child Children [ | | vertices USE {`Set.union`} {Set.empty} : {Set.Set Vertex} ] - --- All vertices from the righthandside of a rule -SEM HsToken - | AGLocal lhs.vertices = Set.singleton $ VChild @var - | AGField lhs.vertices = Set.singleton $ VAttr (if @field == _LHS then Inh - else if @field == _LOC then Loc - else Syn) @field @attr - --- Gather vertices for an expression (make a higher order child) -SEM Expression - | Expression lhs.vertices = Set.unions $ map (\tok -> vertices_Syn_HsToken - (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks - --- Gather vertices at patterns -SEM Pattern - | Alias loc.vertex = if @field == _INST then VChild @attr - else VAttr (if @field == _LHS then Syn - else if @field == _LOC then Loc - else Inh) @field @attr - lhs.vertices = Set.insert @loc.vertex @pat.vertices - --- Gather vertices for children --- --- The behavior for merged children is a bit more complicated (and ignored for now) -SEM Child - | Child loc.vertex = VChild @name - loc.synvertices = map (VAttr Syn @name) . Map.keys $ @loc.syn - loc.inhvertices = map (VAttr Inh @name) . Map.keys $ @loc.inh - lhs.vertices = case @tp of -- only Nonterminal children need to be in dependency graph - NT _ _ _ -> Set.insert @loc.vertex $ Set.fromList (@loc.synvertices ++ @loc.inhvertices) - _ -> Set.empty - --- Add extra vertex for a rule -SEM Rule - | Rule loc.vertex = VRule @loc.rulename - lhs.vertices = Set.insert @loc.vertex $ @pattern.vertices `Set.union` @rhs.vertices - --- Combine all vertices for a production -SEM Production - | Production loc.vertices = @rules.vertices `Set.union` @children.vertices - --- Gather edges -ATTR Rule Rules - Child Children [ | | edges USE {`Set.union`} {Set.empty} : {Set.Set Edge} ] - --- Gather edges for a rule -SEM Rule - | Rule loc.edgesout = map ((,) @loc.vertex) (Set.toList @rhs.vertices) - loc.edgesin = map (flip (,) @loc.vertex) (Set.toList @pattern.vertices) - lhs.edges = Set.fromList $ @loc.edgesout ++ @loc.edgesin - --- When a child is defined by a higher order attribute and the late binding option --- is enabled, we refer to the additional inherited attribute under the hood, hence --- we need to tell the dependency analysis about this in order to actually have the --- attribute available when we attach the child. --- Note that the dependencies on the rule that creates the semantics of the child --- is handled elsewhere by mapping an "inst"-attribute to the right child vertex. -SEM Child | Child - loc.childIsDeforested = case @tp of - NT _ _ defor -> defor - _ -> False - loc.higherOrderEdges = case @kind of - ChildAttr | lateHigherOrderBinding @lhs.options && not @loc.childIsDeforested - -> [(@loc.vertex, VAttr Inh _LHS idLateBindingAttr)] - _ -> [] -- attribute is not referenced implicitly - loc.aroundEdges = if @loc.hasArounds - then [(@loc.vertex, VAttr Syn _LOC (Ident (getName @name ++ "_around") (getPos @name)))] - else [] - --- Gather edges for a child -SEM Child - | Child loc.edgesout = @loc.higherOrderEdges - loc.edgesin = map (flip (,) @loc.vertex) @loc.synvertices - lhs.edges = Set.fromList (@loc.edgesout ++ @loc.edgesin) - --- Add manual attribute dependencies -ATTR Nonterminals Nonterminal [ manualDeps : AttrOrderMap | | ] -ATTR Productions Production [ manualDeps : {Map ConstructorIdent (Set Dependency)} | | ] - -SEM Grammar | Grammar nonts.manualDeps = @manualAttrOrderMap -SEM Nonterminal | Nonterminal prods.manualDeps = Map.findWithDefault Map.empty @nt @lhs.manualDeps -SEM Production | Production - loc.manualDeps = Map.findWithDefault Set.empty @con @lhs.manualDeps - loc.manualEdges = Set.map depToEdge @loc.manualDeps - -{ --- a depends on b, thus a is a successor of b -depToEdge :: Dependency -> Edge -depToEdge (Dependency a b) = (occToVertex False b, occToVertex True a) - -occToVertex :: Bool -> Occurrence -> Vertex -occToVertex _ (OccRule nm) = VRule nm -occToVertex isDependency (OccAttr c a) - | c == _LOC = VAttr Syn c a -- local attributes are treated as synthesized attrs of 'loc' - | c == _INST = VChild a -- higher-order attributes are treated as children - | otherwise = VAttr kind c a where - kind | isDependency && c == _LHS = Inh -- these dependencies have the property that - | isDependency && c /= _LHS = Syn -- they can all be faked by writing a 'const' rule - | not isDependency && c == _LHS = Syn -- Perhaps we should also allow other forms of dependencies - | not isDependency && c /= _LHS = Inh -- as well, such as two inherited attributes, which would - -- force them in different visits -} - --- Combine all edges for a production -SEM Production - | Production loc.edges = @rules.edges `Set.union` @children.edges - --- Find all child nonterminal names for a production -ATTR Child Children [ | | nontnames USE {++} {[]} : {[(Identifier, Identifier)]}] - -SEM Child - | Child lhs.nontnames = case @tp of - NT nont _ _ -> [(@name, nont)] - _ -> [] - --- Return a dependency graph for each production -ATTR Production [ | | depgraph : {ProdDependencyGraph} ] -ATTR Productions [ | | depgraph USE {:} {[]} : {[ProdDependencyGraph]} ] - -SEM Production - | Production lhs.depgraph = ProdDependencyGraph { pdgVertices = Set.toList @loc.vertices - , pdgEdges = Set.toList @loc.edges - , pdgRules = @rules.erules - , pdgChilds = @children.echilds - , pdgProduction = @con - , pdgChildMap = @children.nontnames - , pdgConstraints = @constraints - , pdgParams = @params } - -------------------------------------------------------------------------------- --- Dependency graph per nonterminal -------------------------------------------------------------------------------- - --- Vertices are just all inherited and syntesized attributes -SEM Nonterminal - | Nonterminal loc.synvertices = map (VAttr Syn @nt) . Map.keys $ @syn - loc.inhvertices = map (VAttr Inh @nt) . Map.keys $ @inh - loc.vertices = @loc.synvertices ++ @loc.inhvertices - --- Construct nonterminal dependency graph for production -SEM Nonterminal - | Nonterminal loc.nontgraph = NontDependencyGraph { ndgVertices = @loc.vertices - , ndgEdges = [] } - --- Create dependency information for nonterminal and pass it upwards -ATTR Nonterminal [ | | depinfo : {NontDependencyInformation} ] -ATTR Nonterminals [ | | depinfo USE {:} {[]} : {[NontDependencyInformation]} ] - -SEM Nonterminal - | Nonterminal lhs.depinfo = NontDependencyInformation { ndiNonterminal = @nt - , ndiParams = @params - , ndiInh = Map.keys @inh - , ndiSyn = Map.keys @syn - , ndiDepGraph = @loc.nontgraph - , ndiProds = @prods.depgraph - , ndiRecursive = @loc.recursive - , ndiHoInfo = @loc.hoInfo - , ndiClassCtxs = @loc.classContexts - } - -------------------------------------------------------------------------------- --- Call the kennedy-warren algorithm -------------------------------------------------------------------------------- -ATTR Grammar [ | | output : {ExecutionPlan} - depgraphs : {PP_Doc} - visitgraph : {PP_Doc} - errors : {Seq Error} ] - -SEM Grammar - | Grammar (lhs.output, lhs.depgraphs, lhs.visitgraph, lhs.errors) - = let lazyPlan = kennedyWarrenLazy @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings - in if visit @lhs.options && withCycle @lhs.options - then case kennedyWarrenOrder @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings of - Left e -> (lazyPlan,empty,empty,Seq.singleton e) - Right (o,d,v) -> (o,d,v,Seq.empty) - else (lazyPlan,empty,empty,Seq.empty) - - +INCLUDE "AbstractSyntax.ag" +INCLUDE "HsToken.ag" +INCLUDE "Expression.ag" +INCLUDE "Patterns.ag" +INCLUDE "DistChildAttr.ag" +INCLUDE "ExecutionPlanPre.ag" +INCLUDE "ExecutionPlanCommon.ag" + +imports +{ +import AbstractSyntax +import HsToken +import Expression +import Patterns +import Options +import PPUtil +import Pretty +import Knuth1 +import KennedyWarren +import ExecutionPlan +import Data.Maybe +import Debug.Trace +import Data.Set(Set) +import Data.Map(Map) +import Data.Sequence(Seq) +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import Data.Monoid(mappend,mempty) +} + +------------------------------------------------------------------------------- +-- Dependency graph per production +------------------------------------------------------------------------------- +-- Gather vertices +ATTR HsToken Expression + Rule Rules + Pattern Patterns + Child Children [ | | vertices USE {`Set.union`} {Set.empty} : {Set.Set Vertex} ] + +-- All vertices from the righthandside of a rule +SEM HsToken + | AGLocal lhs.vertices = Set.singleton $ VChild @var + | AGField lhs.vertices = Set.singleton $ VAttr (if @field == _LHS then Inh + else if @field == _LOC then Loc + else Syn) @field @attr + +-- Gather vertices for an expression (make a higher order child) +SEM Expression + | Expression lhs.vertices = Set.unions $ map (\tok -> vertices_Syn_HsToken + (wrap_HsToken (sem_HsToken tok) Inh_HsToken)) @tks + +-- Gather vertices at patterns +SEM Pattern + | Alias loc.vertex = if @field == _INST then VChild @attr + else VAttr (if @field == _LHS then Syn + else if @field == _LOC then Loc + else Inh) @field @attr + lhs.vertices = Set.insert @loc.vertex @pat.vertices + +-- Gather vertices for children +-- +-- The behavior for merged children is a bit more complicated (and ignored for now) +SEM Child + | Child loc.vertex = VChild @name + loc.synvertices = map (VAttr Syn @name) . Map.keys $ @loc.syn + loc.inhvertices = map (VAttr Inh @name) . Map.keys $ @loc.inh + lhs.vertices = case @tp of -- only Nonterminal children need to be in dependency graph + NT _ _ _ -> Set.insert @loc.vertex $ Set.fromList (@loc.synvertices ++ @loc.inhvertices) + _ -> Set.empty + +-- Add extra vertex for a rule +SEM Rule + | Rule loc.vertex = VRule @loc.rulename + lhs.vertices = Set.insert @loc.vertex $ @pattern.vertices `Set.union` @rhs.vertices + +-- Combine all vertices for a production +SEM Production + | Production loc.vertices = @rules.vertices `Set.union` @children.vertices + +-- Gather edges +ATTR Rule Rules + Child Children [ | | edges USE {`Set.union`} {Set.empty} : {Set.Set Edge} ] + +-- Gather edges for a rule +SEM Rule + | Rule loc.edgesout = map ((,) @loc.vertex) (Set.toList @rhs.vertices) + loc.edgesin = map (flip (,) @loc.vertex) (Set.toList @pattern.vertices) + lhs.edges = Set.fromList $ @loc.edgesout ++ @loc.edgesin + +-- When a child is defined by a higher order attribute and the late binding option +-- is enabled, we refer to the additional inherited attribute under the hood, hence +-- we need to tell the dependency analysis about this in order to actually have the +-- attribute available when we attach the child. +-- Note that the dependencies on the rule that creates the semantics of the child +-- is handled elsewhere by mapping an "inst"-attribute to the right child vertex. +SEM Child | Child + loc.childIsDeforested = case @tp of + NT _ _ defor -> defor + _ -> False + loc.higherOrderEdges = case @kind of + ChildAttr | lateHigherOrderBinding @lhs.options && not @loc.childIsDeforested + -> [(@loc.vertex, VAttr Inh _LHS idLateBindingAttr)] + _ -> [] -- attribute is not referenced implicitly + loc.aroundEdges = if @loc.hasArounds + then [(@loc.vertex, VAttr Syn _LOC (Ident (getName @name ++ "_around") (getPos @name)))] + else [] + +-- Gather edges for a child +SEM Child + | Child loc.edgesout = @loc.higherOrderEdges + loc.edgesin = map (flip (,) @loc.vertex) @loc.synvertices + lhs.edges = Set.fromList (@loc.edgesout ++ @loc.edgesin) + +-- Add manual attribute dependencies +ATTR Nonterminals Nonterminal [ manualDeps : AttrOrderMap | | ] +ATTR Productions Production [ manualDeps : {Map ConstructorIdent (Set Dependency)} | | ] + +SEM Grammar | Grammar nonts.manualDeps = @manualAttrOrderMap +SEM Nonterminal | Nonterminal prods.manualDeps = Map.findWithDefault Map.empty @nt @lhs.manualDeps +SEM Production | Production + loc.manualDeps = Map.findWithDefault Set.empty @con @lhs.manualDeps + loc.manualEdges = Set.map depToEdge @loc.manualDeps + +{ +-- a depends on b, thus a is a successor of b +depToEdge :: Dependency -> Edge +depToEdge (Dependency a b) = (occToVertex False b, occToVertex True a) + +occToVertex :: Bool -> Occurrence -> Vertex +occToVertex _ (OccRule nm) = VRule nm +occToVertex isDependency (OccAttr c a) + | c == _LOC = VAttr Syn c a -- local attributes are treated as synthesized attrs of 'loc' + | c == _INST = VChild a -- higher-order attributes are treated as children + | otherwise = VAttr kind c a where + kind | isDependency && c == _LHS = Inh -- these dependencies have the property that + | isDependency && c /= _LHS = Syn -- they can all be faked by writing a 'const' rule + | not isDependency && c == _LHS = Syn -- Perhaps we should also allow other forms of dependencies + | not isDependency && c /= _LHS = Inh -- as well, such as two inherited attributes, which would + -- force them in different visits +} + +-- Combine all edges for a production +SEM Production + | Production loc.edges = @rules.edges `Set.union` @children.edges + +-- Find all child nonterminal names for a production +ATTR Child Children [ | | nontnames USE {++} {[]} : {[(Identifier, Identifier)]}] + +SEM Child + | Child lhs.nontnames = case @tp of + NT nont _ _ -> [(@name, nont)] + _ -> [] + +-- Return a dependency graph for each production +ATTR Production [ | | depgraph : {ProdDependencyGraph} ] +ATTR Productions [ | | depgraph USE {:} {[]} : {[ProdDependencyGraph]} ] + +SEM Production + | Production lhs.depgraph = ProdDependencyGraph { pdgVertices = Set.toList @loc.vertices + , pdgEdges = Set.toList @loc.edges + , pdgRules = @rules.erules + , pdgChilds = @children.echilds + , pdgProduction = @con + , pdgChildMap = @children.nontnames + , pdgConstraints = @constraints + , pdgParams = @params } + +------------------------------------------------------------------------------- +-- Dependency graph per nonterminal +------------------------------------------------------------------------------- + +-- Vertices are just all inherited and syntesized attributes +SEM Nonterminal + | Nonterminal loc.synvertices = map (VAttr Syn @nt) . Map.keys $ @syn + loc.inhvertices = map (VAttr Inh @nt) . Map.keys $ @inh + loc.vertices = @loc.synvertices ++ @loc.inhvertices + +-- Construct nonterminal dependency graph for production +SEM Nonterminal + | Nonterminal loc.nontgraph = NontDependencyGraph { ndgVertices = @loc.vertices + , ndgEdges = [] } + +-- Create dependency information for nonterminal and pass it upwards +ATTR Nonterminal [ | | depinfo : {NontDependencyInformation} ] +ATTR Nonterminals [ | | depinfo USE {:} {[]} : {[NontDependencyInformation]} ] + +SEM Nonterminal + | Nonterminal lhs.depinfo = NontDependencyInformation { ndiNonterminal = @nt + , ndiParams = @params + , ndiInh = Map.keys @inh + , ndiSyn = Map.keys @syn + , ndiDepGraph = @loc.nontgraph + , ndiProds = @prods.depgraph + , ndiRecursive = @loc.recursive + , ndiHoInfo = @loc.hoInfo + , ndiClassCtxs = @loc.classContexts + } + +------------------------------------------------------------------------------- +-- Call the kennedy-warren algorithm +------------------------------------------------------------------------------- +ATTR Grammar [ | | output : {ExecutionPlan} + depgraphs : {PP_Doc} + visitgraph : {PP_Doc} + errors : {Seq Error} ] + +SEM Grammar + | Grammar (lhs.output, lhs.depgraphs, lhs.visitgraph, lhs.errors) + = let lazyPlan = kennedyWarrenLazy @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings + in if visit @lhs.options && withCycle @lhs.options + then case kennedyWarrenOrder @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings of + Left e -> (lazyPlan,empty,empty,Seq.singleton e) + Right (o,d,v) -> (o,d,v,Seq.empty) + else (lazyPlan,empty,empty,Seq.empty) + + diff --git a/src-ag/LOAG/Order.ag b/src-ag/LOAG/Order.ag --- a/src-ag/LOAG/Order.ag +++ b/src-ag/LOAG/Order.ag @@ -1,435 +1,435 @@ -INCLUDE "AbstractSyntax" -INCLUDE "Patterns" -INCLUDE "CodeSyntax" -INCLUDE "Expression" -INCLUDE "HsToken" -INCLUDE "LOAG/Rep" -INCLUDE "LOAG/Prepare" -INCLUDE "ExecutionPlanCommon" - -MODULE {LOAG.Order} -{} -{} -imports{ -import qualified Data.Array as A -import qualified Data.Map as Map -import qualified Data.IntMap as IMap -import qualified Data.Set as Set -import qualified Data.IntSet as IS -import qualified Data.Sequence as Seq -import qualified CommonTypes as CT -import Control.Monad (forM,when) -import Control.Monad.ST -import Data.Maybe(catMaybes) -import Data.Monoid(mappend,mempty) -import Data.STRef -import AbstractSyntax -import qualified LOAG.AOAG as AOAG -import LOAG.Common -import LOAG.Chordal -import LOAG.Rep -import LOAG.Graphs -import CodeSyntax -import Data.Maybe (isJust, fromJust) -import ExecutionPlan -import GrammarInfo -import HsToken (HsToken(..)) -import Pretty -import qualified System.IO as IO -import System.IO.Unsafe -} - -{ -fst' (a,_,_) = a -snd' (_,b,_) = b -trd' (_,_,c) = c -} - -ATTR Grammar [ | | - output : ExecutionPlan - ads : {Maybe PP_Doc} - errors : {Seq.Seq Error}] - -SEM Grammar | Grammar - lhs.errors = either Seq.singleton (const Seq.empty) @loc.schedRes - lhs.ads = case either (const []) trd' @loc.schedRes of - [] -> Nothing - ads -> Just $ ppAds @lhs.options @nonts.pmp ads - lhs.output = ExecutionPlan @nonts.enonts @typeSyns @wrappers @derivings - - nonts.sched = either (const Map.empty) snd' @loc.schedRes - nonts.tdp = either (error "no tdp") (fromJust.fst') @loc.schedRes - - loc.schedRes = if CT.loag @lhs.options - then if CT.aoag @lhs.options - then AOAG.schedule @smf.self @self @loc.ag @nonts.ads - else @loc.loagRes - else Right (Nothing,Map.empty,[]) - loc.loagRes = let putStrLn s = when (verbose @lhs.options) (IO.putStrLn s) - in Right $ unsafePerformIO $ scheduleLOAG @loc.ag putStrLn @lhs.options - loc.ag = repToAg @smf.self @self - - nonts.res_ads = either (const []) trd' @loc.schedRes - --- Gather the fake dependencies from the ads result of AOAG - -ATTR Nonterminals Nonterminal Productions Production - [ res_ads : {[Edge]} || ] -ATTR Nonterminals Nonterminal - [ || fdps USE {Map.union} {Map.empty} : AttrOrderMap ] - -SEM Nonterminal | Nonterminal - lhs.fdps = Map.singleton @nt @prods.fdps - -ATTR Productions Production [ || - fdps USE {Map.union} {Map.empty} : {Map.Map ConstructorIdent (Set Dependency)} ] - -SEM Production | Production - lhs.fdps = - let op d@(f,t) ds - | fst (argsOf $ findWithErr @lhs.pmpf "fdps" f) == (@lhs.dty,getName @con) - = Set.insert (edgeToDep @lhs.pmpf d) ds - | otherwise - = ds - in Map.singleton @con $ foldr op Set.empty @lhs.res_ads -{ -data AltAttr = AltAttr Identifier Identifier Bool - deriving (Eq, Ord, Show) - -edgeToDep :: PMP -> Edge -> Dependency -edgeToDep pmp (f,t) = - Dependency (OccAttr (identifier f1) (identifier i1)) - (OccAttr (identifier f2) (identifier i2)) - where (MyOccurrence (_,f1) (i1,_),MyOccurrence (_,f2) (i2,_)) - = (findWithErr pmp "edgeToDep" f, - findWithErr pmp "edgeToDep" t) - -ppAds :: Options -> PMP -> [Edge] -> PP_Doc -ppAds opts pmp = foldr ((>-<) . ppEdge opts pmp) empty - -ppEdge :: Options -> PMP -> Edge -> PP_Doc -ppEdge opts pmp (f,t) = - text sem >#< text (show ty) >|< " | " >|< text p >|< " " - >|< ppOcc pmp f >|< text " < " >|< ppOcc pmp t - where (MyOccurrence ((ty,p),_) _) = pmp Map.! f - sem | lcKeywords opts = "sem" - | otherwise = "SEM" - -ppOcc :: PMP -> Vertex -> PP_Doc -ppOcc pmp v = text f >|< text "." >|< fst a - where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v - -} - --- Construct Execution Plan - -ATTR Nonterminals Nonterminal [ - visMapf : {IMap.IntMap Int} - tdp : TDPRes || - enonts USE {(++)} {[]} : ENonterminals - visMap USE {IMap.union} {IMap.empty} : {IMap.IntMap Int}] - -SEM Grammar - | Grammar nonts.visMapf = @nonts.visMap - nonts.visitnum = 0 - -SEM Nonterminal - | Nonterminal - loc.initial = @lhs.visitnum - loc.vnums = zipWith const [@loc.initial..] @segments - loc.initialVisit = @vnums - loc.nextVis = Map.fromList $ (@loc.initial + length @vnums, NoneVis) - : [(v, OneVis v) | v <- @vnums ] - loc.prevVis = Map.fromList $ (@loc.initial, NoneVis) - : [(v+1, OneVis v) | v <- @vnums ] - loc.visMap = let op vnr (MySegment visnr ins syns _ _) = - IMap.fromList $ zip syns (repeat vnr) - in IMap.unions $ zipWith op [@loc.initial..] @mysegments - lhs.enonts = [ENonterminal - @nt - @params - @loc.classContexts - @loc.initial - @loc.initialVisit - @loc.nextVis - @loc.prevVis - @prods.eprods - @loc.recursive - @loc.hoInfo ] - -ATTR Productions Production [ - visMapf : {IMap.IntMap Int} - tdp : TDPRes || - eprods USE {(++)} {[]} : EProductions ] - -SEM Production - | Production - segs.ruleMap = @rules.ruleMap - segs.done = (Set.empty, Set.empty, Set.empty, Set.empty) - loc.intros = let intro (Child nm _ kind) - | kind == ChildAttr = Nothing - | otherwise = Just $ ChildIntro nm - in catMaybes $ map intro @children.self - lhs.eprods = - let ((Visit ident from to inh syn steps kind):vss) = @segs.evisits - steps' = @loc.intros ++ steps - visits | null @segs.evisits = [] - | otherwise = - ((Visit ident from to inh syn steps' kind):vss) - in [EProduction - @con - @params - @constraints - @rules.erules - @children.echilds - visits ] - -ATTR Nonterminals Nonterminal Productions Production MySegments MySegment - [ | visitnum : Int | ] - --- Visit nums should be the same for each production, but different globally -SEM Productions - | Cons tl.visitnum = @lhs.visitnum - lhs.visitnum = @hd.visitnum - -SEM MySegment | MySegment +visitnum = (+1) -ATTR MySegments MySegment [ - -- maps which attribute occurrence is calculated in which visit - visMapf : {IMap.IntMap Int} | | ] - -ATTR MySegments MySegment [ - ps : PLabel - ruleMap : {Map.Map MyOccurrence Identifier} - nmprf : NMP_R - options : {Options} - tdp : TDPRes - done : { (Set.Set MyOccurrence, Set.Set FLabel - , Set.Set Identifier, Set.Set (FLabel,Int))} - ||] - -ATTR MySegments [|| evisits USE {:} {[]} : {Visits}] -ATTR MySegment [|| - evisits : {Visit} - -- synthesized attribute occurrences of this segment - synsO : {[Int]} - visnr : Int - done : { (Set.Set MyOccurrence, Set.Set FLabel - ,Set.Set Identifier, Set.Set (FLabel,Int))}] - -SEM MySegments - | Cons hd.done = @lhs.done - tl.done = @hd.done - -SEM MySegment - | MySegment - loc.inhs = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @inhAttr - loc.syns = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @synAttr - loc.inhsO= maybe (error "segment not instantiated") id @inhOccs - loc.synsO= maybe (error "segment not instantiated") id @synOccs - lhs.visnr= @visnr - loc.kind = if monadic @lhs.options then VisitMonadic else VisitPure True - lhs.evisits = Visit @lhs.visitnum @lhs.visitnum (@lhs.visitnum+1) - @loc.inhs @loc.syns @loc.steps @loc.kind - loc.steps = if monadic @lhs.options - then [Sim @loc.vss] else [PureGroup @loc.vss True] - (loc.vss,lhs.done) = (runST $ getVss @lhs.done @lhs.ps @lhs.tdp @synsO - @lhs.lfpf @lhs.nmprf @lhs.pmpf @lhs.pmprf @lhs.fty - @lhs.visMapf @lhs.ruleMap @lhs.hoMapf) - -{ -getVss (done,intros,rules,vnrs) ps tdp synsO lfp nmpr pmp pmpr fty visMap ruleMap hoMap = do - ref <- newSTRef done - introed <- newSTRef intros - ruleref <- newSTRef rules - vnrsref <- newSTRef vnrs - lists <- forM synsO (visit ref introed ruleref vnrsref . (pmp Map.!)) - done <- readSTRef ref - intros <- readSTRef introed - rules <- readSTRef ruleref - vnrs <- readSTRef vnrsref - return (concat lists, (done, intros, rules, vnrs)) - where - hochildren = maybe Set.empty id $ Map.lookup ps hoMap - visit ref introed ruleref vnrsref o@(MyOccurrence (_,f) (_,d)) = do - visited <- readSTRef ref - if (o `Set.member` visited) - then return [] -- already visited - else do -- prevent doubles - modifySTRef ref (Set.insert o) - if inOutput - then do -- has to be calculated in this sequence - rest' <- rest - locs' <- locs - sem' <- sem o - return $ (rest' ++ locs' ++ sem') - else if "lhs" == (snd $ argsOf o) - then return [] -- inherited of parent, nothing todo - else do -- other input occurrence, perform visit - locs' <- locs - rest' <- rest - visit'<- toVisit o - return (rest' ++ locs' ++ visit') - where preds = maybe [] (IS.toList . (tdp A.!)) $ Map.lookup o pmpr - rest = forM preds (visit ref introed ruleref vnrsref. (pmp Map.!)) - >>= (return . concat) - free = maybe [] (Set.toList) $ Map.lookup o lfp - locs = forM free (visit ref introed ruleref vnrsref) - >>= (return . concat) - sem o = do rules <- readSTRef ruleref - if r `Set.member` rules - then return [] - else do writeSTRef ruleref (r `Set.insert` rules) - return [Sem r] - where r = maybe (error "ruleMap") id $ Map.lookup o ruleMap - inOutput = f == "lhs" && d == Syn || f /= "lhs" && d == Inh - toVisit o = do - vnrs <- readSTRef vnrsref - if (child,visnr) `Set.member` vnrs - then return [] - else writeSTRef vnrsref ((child,visnr) `Set.insert` vnrs) >> - if child `Set.member` hochildren - then do intros <- readSTRef introed - case child `Set.member` intros of - True -> return [cvisit] - False -> do - writeSTRef introed (Set.insert child intros) - let occ = (ps,"inst") >.< (child, AnyDir) - preds = Set.toList $ setConcatMap rep $ - lfp Map.! occ - rep :: MyOccurrence -> Set.Set MyOccurrence - rep occ | isLoc occ = Set.insert occ $ - setConcatMap rep $ lfp Map.! occ - | otherwise = Set.singleton occ - rest <- forM preds - (visit ref introed ruleref vnrsref) - sem' <- sem occ - return $ (concat rest) ++ - sem' ++ - [ChildIntro (identifier child)] ++ - [cvisit] - else return [cvisit] - where cvisit= ChildVisit (identifier child) ntid visnr - child = snd $ argsOf o - ntid = ((\(NT name _ _ )-> name) . fromMyTy) nt - visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o)) - nt = fty Map.! (ps,child) -} - -ATTR Nonterminals Nonterminal [ - sched : {InterfaceRes} ||] -SEM Nonterminal - | Nonterminal - loc.assigned = findWithErr @lhs.sched "could not const. interfaces" - (getName @nt) - loc.mx = if Map.null @lhs.sched - then 0 - else let mx = fst $ IMap.findMax @loc.assigned in - if even mx then mx else mx + 1 - loc.mysegments = - map (\i -> MySegment ((@loc.mx - i) `div` 2) - (maybe [] id $ IMap.lookup i @loc.assigned) - (maybe [] id $ IMap.lookup (i-1) @loc.assigned) - Nothing Nothing) - [@loc.mx,@loc.mx-2 .. 2] - loc.segments = - map (\(MySegment visnr is ss _ _) -> - CSegment (Map.unions $ map (vertexToAttr @lhs.nmp) is) - (Map.unions $ map (vertexToAttr @lhs.nmp) ss)) - @loc.mysegments - -ATTR Productions Production [ mysegments : MySegments || ] -SEM Production - | Production - inst.segs : MySegments - --translate from attribute to occurrences - inst.segs = - map (\(MySegment visnr inhs syns _ _) -> - MySegment visnr inhs syns - (Just $ map (@lhs.pmprf Map.!) $ - handAllOut (@loc.ps,"lhs") $ - map (@lhs.nmp Map.!) inhs) - (Just $ map (@lhs.pmprf Map.!) $ - handAllOut (@loc.ps,"lhs") $ - map (@lhs.nmp Map.!) syns) - ) @lhs.mysegments - -{ -repToAg :: LOAGRep -> Grammar -> Ag -repToAg sem (Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) = - Ag bounds_s bounds_p de (map toNt dats) - where - pmp = (pmp_LOAGRep_LOAGRep sem) - pmpr = (pmpr_LOAGRep_LOAGRep sem) - nmp = (nmp_LOAGRep_LOAGRep sem) - nmpr = (nmpr_LOAGRep_LOAGRep sem) - genA = gen_LOAGRep_LOAGRep sem - fieldM = fieldMap_LOAGRep_LOAGRep sem - genEdge (f,t) = (gen f, gen t) - fsInP = map2F (fsInP_LOAGRep_LOAGRep sem) - siblings (f, t) = ofld A.! f == ofld A.! t - ofld = (ofld_LOAGRep_LOAGRep sem) - sfp = map2F' (sfp_LOAGRep_LOAGRep sem) - afp = filter inOutput . ap - ap = map (findWithErr pmpr "building ap") . map2F (ap_LOAGRep_LOAGRep sem) - inss = inss_LOAGRep_LOAGRep sem - gen v = genA A.! v - ain = map (findWithErr nmpr "building an") . map2F (ain_LOAGRep_LOAGRep sem) - asn = map (findWithErr nmpr "building an") . map2F (asn_LOAGRep_LOAGRep sem) - inOutput = not . inContext - inContext f = (f1 == "lhs" && d1 == Inh || f1 /= "lhs" && d1 == Syn) - where (MyOccurrence (_,f1) (_,d1)) = pmp Map.! f - de = [ e | p <- ps, e <- dpe p ] - dpe p = [ (findWithErr pmpr "building dpe" a, b) - | b <- ap p, a <- Set.toList $ sfp (findWithErr pmp "fetching sfp" b) ] - ps = ps_LOAGRep_LOAGRep sem - bounds_p = if Map.null pmp then (0,-1) - else (fst $ Map.findMin pmp, fst $ Map.findMax pmp) - bounds_s = if Map.null nmp then (0,-1) - else (fst $ Map.findMin nmp, fst $ Map.findMax nmp) - - - - toNt :: Nonterminal -> Nt - toNt (Nonterminal ntid _ _ _ prods) = Nt nt dpf dpt - (addD Inh $ ain ty) (addD Syn $ asn ty) (map (toPr ty) prods) - where nt = getName ntid - ty = TyData nt - dpt = [ (as, ai) | ai <- ain ty - , as <- nub$ [ gen s | - i <- inss A.! ai - , s <- map (pmpr Map.!) $ - Set.toList (sfp $ pmp Map.! i) - , siblings (s,i)]] - dpf = [ (ai, as) | as <- asn ty - , ai <- nub$ [ gen i | - s <- inss A.! as - , i <- map (pmpr Map.!) $ - Set.toList (sfp $ pmp Map.! s) - , siblings (i,s)]] - addD d = map (\i -> (i,inss A.! i,d)) - toPr :: MyType -> Production -> Pr - toPr ty (Production con _ _ _ _ _ _) = - Pr p dpp fc_occs (map toFd $ fsInP p) - where p = (ty, getName con) - dpp = [ (f',t) - | t <- afp p, f <- (Set.toList $ sfp (pmp Map.! t)) - , let f' = pmpr Map.! f - , not (siblings (f',t))] - fc_occs = foldl' match [] fss - where fss = fsInP p - match s fs = [ ready (inp, out) lhs | inp <- Set.toList inhs - , out <- Set.toList syns] ++ s - where ((inhs, syns), lhs) - | (snd fs) /= "lhs" = - (swap (fieldM Map.! fs),False) - | otherwise = (fieldM Map.! fs, True) - ready e@(f,t) b = (e', genEdge e', b) - where e' = (pmpr Map.! f, pmpr Map.! t) - toFd :: (PLabel, FLabel) -> Fd - toFd fs@((TyData ty, pr), fd) = Fd fd ty inhs syns - where (is,ss) = fieldM Map.! fs - inhs = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList is - syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss - - -} +INCLUDE "AbstractSyntax" +INCLUDE "Patterns" +INCLUDE "CodeSyntax" +INCLUDE "Expression" +INCLUDE "HsToken" +INCLUDE "LOAG/Rep" +INCLUDE "LOAG/Prepare" +INCLUDE "ExecutionPlanCommon" + +MODULE {LOAG.Order} +{} +{} +imports{ +import qualified Data.Array as A +import qualified Data.Map as Map +import qualified Data.IntMap as IMap +import qualified Data.Set as Set +import qualified Data.IntSet as IS +import qualified Data.Sequence as Seq +import qualified CommonTypes as CT +import Control.Monad (forM,when) +import Control.Monad.ST +import Data.Maybe(catMaybes) +import Data.Monoid(mappend,mempty) +import Data.STRef +import AbstractSyntax +import qualified LOAG.AOAG as AOAG +import LOAG.Common +import LOAG.Chordal +import LOAG.Rep +import LOAG.Graphs +import CodeSyntax +import Data.Maybe (isJust, fromJust) +import ExecutionPlan +import GrammarInfo +import HsToken (HsToken(..)) +import Pretty +import qualified System.IO as IO +import System.IO.Unsafe +} + +{ +fst' (a,_,_) = a +snd' (_,b,_) = b +trd' (_,_,c) = c +} + +ATTR Grammar [ | | + output : ExecutionPlan + ads : {Maybe PP_Doc} + errors : {Seq.Seq Error}] + +SEM Grammar | Grammar + lhs.errors = either Seq.singleton (const Seq.empty) @loc.schedRes + lhs.ads = case either (const []) trd' @loc.schedRes of + [] -> Nothing + ads -> Just $ ppAds @lhs.options @nonts.pmp ads + lhs.output = ExecutionPlan @nonts.enonts @typeSyns @wrappers @derivings + + nonts.sched = either (const Map.empty) snd' @loc.schedRes + nonts.tdp = either (error "no tdp") (fromJust.fst') @loc.schedRes + + loc.schedRes = if CT.loag @lhs.options + then if CT.aoag @lhs.options + then AOAG.schedule @smf.self @self @loc.ag @nonts.ads + else @loc.loagRes + else Right (Nothing,Map.empty,[]) + loc.loagRes = let putStrLn s = when (verbose @lhs.options) (IO.putStrLn s) + in Right $ unsafePerformIO $ scheduleLOAG @loc.ag putStrLn @lhs.options + loc.ag = repToAg @smf.self @self + + nonts.res_ads = either (const []) trd' @loc.schedRes + +-- Gather the fake dependencies from the ads result of AOAG + +ATTR Nonterminals Nonterminal Productions Production + [ res_ads : {[Edge]} || ] +ATTR Nonterminals Nonterminal + [ || fdps USE {Map.union} {Map.empty} : AttrOrderMap ] + +SEM Nonterminal | Nonterminal + lhs.fdps = Map.singleton @nt @prods.fdps + +ATTR Productions Production [ || + fdps USE {Map.union} {Map.empty} : {Map.Map ConstructorIdent (Set Dependency)} ] + +SEM Production | Production + lhs.fdps = + let op d@(f,t) ds + | fst (argsOf $ findWithErr @lhs.pmpf "fdps" f) == (@lhs.dty,getName @con) + = Set.insert (edgeToDep @lhs.pmpf d) ds + | otherwise + = ds + in Map.singleton @con $ foldr op Set.empty @lhs.res_ads +{ +data AltAttr = AltAttr Identifier Identifier Bool + deriving (Eq, Ord, Show) + +edgeToDep :: PMP -> Edge -> Dependency +edgeToDep pmp (f,t) = + Dependency (OccAttr (identifier f1) (identifier i1)) + (OccAttr (identifier f2) (identifier i2)) + where (MyOccurrence (_,f1) (i1,_),MyOccurrence (_,f2) (i2,_)) + = (findWithErr pmp "edgeToDep" f, + findWithErr pmp "edgeToDep" t) + +ppAds :: Options -> PMP -> [Edge] -> PP_Doc +ppAds opts pmp = foldr ((>-<) . ppEdge opts pmp) empty + +ppEdge :: Options -> PMP -> Edge -> PP_Doc +ppEdge opts pmp (f,t) = + text sem >#< text (show ty) >|< " | " >|< text p >|< " " + >|< ppOcc pmp f >|< text " < " >|< ppOcc pmp t + where (MyOccurrence ((ty,p),_) _) = pmp Map.! f + sem | lcKeywords opts = "sem" + | otherwise = "SEM" + +ppOcc :: PMP -> Vertex -> PP_Doc +ppOcc pmp v = text f >|< text "." >|< fst a + where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v + +} + +-- Construct Execution Plan + +ATTR Nonterminals Nonterminal [ + visMapf : {IMap.IntMap Int} + tdp : TDPRes || + enonts USE {(++)} {[]} : ENonterminals + visMap USE {IMap.union} {IMap.empty} : {IMap.IntMap Int}] + +SEM Grammar + | Grammar nonts.visMapf = @nonts.visMap + nonts.visitnum = 0 + +SEM Nonterminal + | Nonterminal + loc.initial = @lhs.visitnum + loc.vnums = zipWith const [@loc.initial..] @segments + loc.initialVisit = @vnums + loc.nextVis = Map.fromList $ (@loc.initial + length @vnums, NoneVis) + : [(v, OneVis v) | v <- @vnums ] + loc.prevVis = Map.fromList $ (@loc.initial, NoneVis) + : [(v+1, OneVis v) | v <- @vnums ] + loc.visMap = let op vnr (MySegment visnr ins syns _ _) = + IMap.fromList $ zip syns (repeat vnr) + in IMap.unions $ zipWith op [@loc.initial..] @mysegments + lhs.enonts = [ENonterminal + @nt + @params + @loc.classContexts + @loc.initial + @loc.initialVisit + @loc.nextVis + @loc.prevVis + @prods.eprods + @loc.recursive + @loc.hoInfo ] + +ATTR Productions Production [ + visMapf : {IMap.IntMap Int} + tdp : TDPRes || + eprods USE {(++)} {[]} : EProductions ] + +SEM Production + | Production + segs.ruleMap = @rules.ruleMap + segs.done = (Set.empty, Set.empty, Set.empty, Set.empty) + loc.intros = let intro (Child nm _ kind) + | kind == ChildAttr = Nothing + | otherwise = Just $ ChildIntro nm + in catMaybes $ map intro @children.self + lhs.eprods = + let ((Visit ident from to inh syn steps kind):vss) = @segs.evisits + steps' = @loc.intros ++ steps + visits | null @segs.evisits = [] + | otherwise = + ((Visit ident from to inh syn steps' kind):vss) + in [EProduction + @con + @params + @constraints + @rules.erules + @children.echilds + visits ] + +ATTR Nonterminals Nonterminal Productions Production MySegments MySegment + [ | visitnum : Int | ] + +-- Visit nums should be the same for each production, but different globally +SEM Productions + | Cons tl.visitnum = @lhs.visitnum + lhs.visitnum = @hd.visitnum + +SEM MySegment | MySegment +visitnum = (+1) +ATTR MySegments MySegment [ + -- maps which attribute occurrence is calculated in which visit + visMapf : {IMap.IntMap Int} | | ] + +ATTR MySegments MySegment [ + ps : PLabel + ruleMap : {Map.Map MyOccurrence Identifier} + nmprf : NMP_R + options : {Options} + tdp : TDPRes + done : { (Set.Set MyOccurrence, Set.Set FLabel + , Set.Set Identifier, Set.Set (FLabel,Int))} + ||] + +ATTR MySegments [|| evisits USE {:} {[]} : {Visits}] +ATTR MySegment [|| + evisits : {Visit} + -- synthesized attribute occurrences of this segment + synsO : {[Int]} + visnr : Int + done : { (Set.Set MyOccurrence, Set.Set FLabel + ,Set.Set Identifier, Set.Set (FLabel,Int))}] + +SEM MySegments + | Cons hd.done = @lhs.done + tl.done = @hd.done + +SEM MySegment + | MySegment + loc.inhs = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @inhAttr + loc.syns = Map.keysSet$ Map.unions $ map (vertexToAttr @lhs.nmp) @synAttr + loc.inhsO= maybe (error "segment not instantiated") id @inhOccs + loc.synsO= maybe (error "segment not instantiated") id @synOccs + lhs.visnr= @visnr + loc.kind = if monadic @lhs.options then VisitMonadic else VisitPure True + lhs.evisits = Visit @lhs.visitnum @lhs.visitnum (@lhs.visitnum+1) + @loc.inhs @loc.syns @loc.steps @loc.kind + loc.steps = if monadic @lhs.options + then [Sim @loc.vss] else [PureGroup @loc.vss True] + (loc.vss,lhs.done) = (runST $ getVss @lhs.done @lhs.ps @lhs.tdp @synsO + @lhs.lfpf @lhs.nmprf @lhs.pmpf @lhs.pmprf @lhs.fty + @lhs.visMapf @lhs.ruleMap @lhs.hoMapf) + +{ +getVss (done,intros,rules,vnrs) ps tdp synsO lfp nmpr pmp pmpr fty visMap ruleMap hoMap = do + ref <- newSTRef done + introed <- newSTRef intros + ruleref <- newSTRef rules + vnrsref <- newSTRef vnrs + lists <- forM synsO (visit ref introed ruleref vnrsref . (pmp Map.!)) + done <- readSTRef ref + intros <- readSTRef introed + rules <- readSTRef ruleref + vnrs <- readSTRef vnrsref + return (concat lists, (done, intros, rules, vnrs)) + where + hochildren = maybe Set.empty id $ Map.lookup ps hoMap + visit ref introed ruleref vnrsref o@(MyOccurrence (_,f) (_,d)) = do + visited <- readSTRef ref + if (o `Set.member` visited) + then return [] -- already visited + else do -- prevent doubles + modifySTRef ref (Set.insert o) + if inOutput + then do -- has to be calculated in this sequence + rest' <- rest + locs' <- locs + sem' <- sem o + return $ (rest' ++ locs' ++ sem') + else if "lhs" == (snd $ argsOf o) + then return [] -- inherited of parent, nothing todo + else do -- other input occurrence, perform visit + locs' <- locs + rest' <- rest + visit'<- toVisit o + return (rest' ++ locs' ++ visit') + where preds = maybe [] (IS.toList . (tdp A.!)) $ Map.lookup o pmpr + rest = forM preds (visit ref introed ruleref vnrsref. (pmp Map.!)) + >>= (return . concat) + free = maybe [] (Set.toList) $ Map.lookup o lfp + locs = forM free (visit ref introed ruleref vnrsref) + >>= (return . concat) + sem o = do rules <- readSTRef ruleref + if r `Set.member` rules + then return [] + else do writeSTRef ruleref (r `Set.insert` rules) + return [Sem r] + where r = maybe (error "ruleMap") id $ Map.lookup o ruleMap + inOutput = f == "lhs" && d == Syn || f /= "lhs" && d == Inh + toVisit o = do + vnrs <- readSTRef vnrsref + if (child,visnr) `Set.member` vnrs + then return [] + else writeSTRef vnrsref ((child,visnr) `Set.insert` vnrs) >> + if child `Set.member` hochildren + then do intros <- readSTRef introed + case child `Set.member` intros of + True -> return [cvisit] + False -> do + writeSTRef introed (Set.insert child intros) + let occ = (ps,"inst") >.< (child, AnyDir) + preds = Set.toList $ setConcatMap rep $ + lfp Map.! occ + rep :: MyOccurrence -> Set.Set MyOccurrence + rep occ | isLoc occ = Set.insert occ $ + setConcatMap rep $ lfp Map.! occ + | otherwise = Set.singleton occ + rest <- forM preds + (visit ref introed ruleref vnrsref) + sem' <- sem occ + return $ (concat rest) ++ + sem' ++ + [ChildIntro (identifier child)] ++ + [cvisit] + else return [cvisit] + where cvisit= ChildVisit (identifier child) ntid visnr + child = snd $ argsOf o + ntid = ((\(NT name _ _ )-> name) . fromMyTy) nt + visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o)) + nt = fty Map.! (ps,child) +} + +ATTR Nonterminals Nonterminal [ + sched : {InterfaceRes} ||] +SEM Nonterminal + | Nonterminal + loc.assigned = findWithErr @lhs.sched "could not const. interfaces" + (getName @nt) + loc.mx = if Map.null @lhs.sched + then 0 + else let mx = fst $ IMap.findMax @loc.assigned in + if even mx then mx else mx + 1 + loc.mysegments = + map (\i -> MySegment ((@loc.mx - i) `div` 2) + (maybe [] id $ IMap.lookup i @loc.assigned) + (maybe [] id $ IMap.lookup (i-1) @loc.assigned) + Nothing Nothing) + [@loc.mx,@loc.mx-2 .. 2] + loc.segments = + map (\(MySegment visnr is ss _ _) -> + CSegment (Map.unions $ map (vertexToAttr @lhs.nmp) is) + (Map.unions $ map (vertexToAttr @lhs.nmp) ss)) + @loc.mysegments + +ATTR Productions Production [ mysegments : MySegments || ] +SEM Production + | Production + inst.segs : MySegments + --translate from attribute to occurrences + inst.segs = + map (\(MySegment visnr inhs syns _ _) -> + MySegment visnr inhs syns + (Just $ map (@lhs.pmprf Map.!) $ + handAllOut (@loc.ps,"lhs") $ + map (@lhs.nmp Map.!) inhs) + (Just $ map (@lhs.pmprf Map.!) $ + handAllOut (@loc.ps,"lhs") $ + map (@lhs.nmp Map.!) syns) + ) @lhs.mysegments + +{ +repToAg :: LOAGRep -> Grammar -> Ag +repToAg sem (Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) = + Ag bounds_s bounds_p de (map toNt dats) + where + pmp = (pmp_LOAGRep_LOAGRep sem) + pmpr = (pmpr_LOAGRep_LOAGRep sem) + nmp = (nmp_LOAGRep_LOAGRep sem) + nmpr = (nmpr_LOAGRep_LOAGRep sem) + genA = gen_LOAGRep_LOAGRep sem + fieldM = fieldMap_LOAGRep_LOAGRep sem + genEdge (f,t) = (gen f, gen t) + fsInP = map2F (fsInP_LOAGRep_LOAGRep sem) + siblings (f, t) = ofld A.! f == ofld A.! t + ofld = (ofld_LOAGRep_LOAGRep sem) + sfp = map2F' (sfp_LOAGRep_LOAGRep sem) + afp = filter inOutput . ap + ap = map (findWithErr pmpr "building ap") . map2F (ap_LOAGRep_LOAGRep sem) + inss = inss_LOAGRep_LOAGRep sem + gen v = genA A.! v + ain = map (findWithErr nmpr "building an") . map2F (ain_LOAGRep_LOAGRep sem) + asn = map (findWithErr nmpr "building an") . map2F (asn_LOAGRep_LOAGRep sem) + inOutput = not . inContext + inContext f = (f1 == "lhs" && d1 == Inh || f1 /= "lhs" && d1 == Syn) + where (MyOccurrence (_,f1) (_,d1)) = pmp Map.! f + de = [ e | p <- ps, e <- dpe p ] + dpe p = [ (findWithErr pmpr "building dpe" a, b) + | b <- ap p, a <- Set.toList $ sfp (findWithErr pmp "fetching sfp" b) ] + ps = ps_LOAGRep_LOAGRep sem + bounds_p = if Map.null pmp then (0,-1) + else (fst $ Map.findMin pmp, fst $ Map.findMax pmp) + bounds_s = if Map.null nmp then (0,-1) + else (fst $ Map.findMin nmp, fst $ Map.findMax nmp) + + + + toNt :: Nonterminal -> Nt + toNt (Nonterminal ntid _ _ _ prods) = Nt nt dpf dpt + (addD Inh $ ain ty) (addD Syn $ asn ty) (map (toPr ty) prods) + where nt = getName ntid + ty = TyData nt + dpt = [ (as, ai) | ai <- ain ty + , as <- nub$ [ gen s | + i <- inss A.! ai + , s <- map (pmpr Map.!) $ + Set.toList (sfp $ pmp Map.! i) + , siblings (s,i)]] + dpf = [ (ai, as) | as <- asn ty + , ai <- nub$ [ gen i | + s <- inss A.! as + , i <- map (pmpr Map.!) $ + Set.toList (sfp $ pmp Map.! s) + , siblings (i,s)]] + addD d = map (\i -> (i,inss A.! i,d)) + toPr :: MyType -> Production -> Pr + toPr ty (Production con _ _ _ _ _ _) = + Pr p dpp fc_occs (map toFd $ fsInP p) + where p = (ty, getName con) + dpp = [ (f',t) + | t <- afp p, f <- (Set.toList $ sfp (pmp Map.! t)) + , let f' = pmpr Map.! f + , not (siblings (f',t))] + fc_occs = foldl' match [] fss + where fss = fsInP p + match s fs = [ ready (inp, out) lhs | inp <- Set.toList inhs + , out <- Set.toList syns] ++ s + where ((inhs, syns), lhs) + | (snd fs) /= "lhs" = + (swap (fieldM Map.! fs),False) + | otherwise = (fieldM Map.! fs, True) + ready e@(f,t) b = (e', genEdge e', b) + where e' = (pmpr Map.! f, pmpr Map.! t) + toFd :: (PLabel, FLabel) -> Fd + toFd fs@((TyData ty, pr), fd) = Fd fd ty inhs syns + where (is,ss) = fieldM Map.! fs + inhs = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList is + syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss + + +} diff --git a/src-ag/LOAG/Prepare.ag b/src-ag/LOAG/Prepare.ag --- a/src-ag/LOAG/Prepare.ag +++ b/src-ag/LOAG/Prepare.ag @@ -1,316 +1,316 @@ -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "CodeSyntax.ag" -INCLUDE "Expression.ag" -INCLUDE "HsToken.ag" -INCLUDE "LOAG/Rep" -INCLUDE "ExecutionPlanPre" - -MODULE {LOAG.Prepare} -{} -{} - -{ --- | Translating UUAGC types to MyTypes -drhs f | f == _LHS = Inh - | f == _LOC = AnyDir - | f == _INST = AnyDir - | otherwise = Syn -dlhs f | f == _LHS = Syn - | f == _LOC = AnyDir - | f == _INST = AnyDir - | otherwise = Inh - -depToEdge :: PMP_R -> PLabel -> Dependency -> Edge -depToEdge pmpr p e = - (findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f1) (getName i1, drhs f1), - findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f2) (getName i2, dlhs f2)) - where Dependency (OccAttr f1 i1) (OccAttr f2 i2) = e - -vertexToAttr :: NMP -> Vertex -> Attributes -vertexToAttr nmp v = Map.singleton (identifier a) (fromMyTy ty) - where (MyAttribute ty (a,_)) = findWithErr nmp "vertexToAttr" v - -} - -SEM Grammar | Grammar - inst.smf : LOAGRep - loc.initO= if Map.null @nonts.pmp then 1 else fst $ Map.findMin @nonts.pmp - inst.smf = - LOAGRep @nonts.ps @nonts.ap @loc.an - @loc.ain @loc.asn @loc.sfp - @nonts.pmp @nonts.pmpr @loc.nmp @loc.nmpr - (A.array (@loc.initO, @loc.initO + Map.size @nonts.gen) $ - Map.toList $ @nonts.gen) - (A.array (1,Map.size @nonts.inss) $ - Map.toList $ @nonts.inss) - (A.array (@loc.initO, @loc.initO + length @nonts.ofld) $ - @nonts.ofld) @nonts.fty @nonts.fieldMap @nonts.fsInP - loc.nmp = Map.fromList $ zip [1..] @loc.atts - loc.nmpr = Map.fromList $ zip @loc.atts [1..] - loc.an = Map.unionWith (++) @loc.ain @loc.asn - loc.ain = @nonts.inhs - loc.asn = @nonts.syns - loc.atts = concat $ Map.elems @loc.an - loc.occs = concat $ Map.elems @nonts.ap - nonts.augM = @manualAttrOrderMap - --- Collecting the attributes -ATTR Nonterminals Nonterminal [ - augM : {Map.Map Identifier (Map.Map Identifier (Set.Set Dependency))} || - inhs USE {Map.union} {Map.empty} : AI_N - syns USE {Map.union} {Map.empty} : AS_N ] - -SEM Nonterminal | Nonterminal - lhs.inhs = let dty = TyData (getName @nt) - in Map.singleton dty (toMyAttr Inh dty @inh) - lhs.syns = let dty = TyData (getName @nt) - in Map.singleton dty (toMyAttr Syn dty @syn) - prods.augM = case Map.lookup @nt @lhs.augM of - Nothing -> Map.empty - Just a -> a - --- Adding all attribute sets to the AG type --- and sending it all down the abstract tree -ATTR Nonterminals Nonterminal Productions Production Children Child - MySegments MySegment [ - ain : {MyType -> MyAttributes} - asn : {MyType -> MyAttributes} - pmpf : PMP - pmprf : PMP_R - lfpf : SF_P - hoMapf: HOMap - fty : FTY - nmp : NMP || ] - -SEM Grammar | Grammar - nonts.ain = map2F @loc.ain - nonts.asn = map2F @loc.asn - nonts.pmpf = @nonts.pmp - nonts.pmprf = @nonts.pmpr - nonts.lfpf = @nonts.lfp - nonts.hoMapf= @nonts.hoMap - nonts.ftyf = @nonts.fty - nonts.fty = @nonts.fty - --- Make sure TDP AND LFPRF are passed around correctly to code-generation -ATTR Nonterminals Nonterminal Productions Production [ - ftyf: FTY ||] - - --- Calculate the set of production labels -SEM Grammar | Grammar - loc.ps = @nonts.ps -ATTR Nonterminals Nonterminal Productions Production [ || - ads USE {(++)} {[]} : {[Edge]} - fieldMap USE {(Map.union)} {Map.empty} : FMap - hoMap USE {(Map.union)} {Map.empty} : HOMap - fsInP USE {(Map.union)} {Map.empty} : FsInP] - -SEM Nonterminals Nonterminal [ || - ps USE {(++)} {([])} : {[PLabel]} ] -SEM Productions [ || - ps USE {:} {([])} : {[PLabel]} ] -SEM Production [ || ps : PLabel ] | Production - loc.ps = (@lhs.dty,getName @con) - lhs.ads = - case Map.lookup @con @lhs.augM of - Nothing -> [] - Just a -> Set.toList $ Set.map (depToEdge @children.pmpr @loc.pll) a - children.dty = @lhs.dty - -ATTR Productions Production [ - augM : {Map.Map Identifier (Set.Set Dependency)} || ] --- We didnt calculate A_P yet, inheriting A_N we can -ATTR Productions Production Rules Rule [ - -- result type of this constructor - dty : {MyType} || ] -ATTR Rules Rule Children Child Expression HsTokensRoot HsTokens HsToken [ - pll : {PLabel} || ] -SEM Nonterminal | Nonterminal - loc.dty = TyData (getName @nt) - -ATTR Nonterminals Nonterminal Productions Production Children Child - FieldAtts FieldAtt [ - an : {MyType -> MyAttributes} - nmprf : NMP_R| - olab : Int -- chained attribute for handing out labels to occurrences - flab : Int |--chained attribute for handing out labels to fields - ap USE {Map.unionWith (++)} {Map.empty} : A_P - gen USE {Map.union} {Map.empty} : {Map Int Int} - inss USE {Map.unionWith (++)} {Map.empty} : {Map Int [Int]} - pmp USE {Map.union} {Map.empty} : PMP - pmpr USE {Map.union} {Map.empty} : PMP_R - -- maps for each occurrence to which field it belongs - ofld USE {(++)} {[]} : {[(Int, Int)]} - fty USE {Map.union} {Map.empty} : FTY - ] - -SEM Grammar | Grammar - nonts.an = map2F @loc.an - nonts.nmprf= @loc.nmpr - nonts.olab = if Map.null @loc.nmp then 0 else (fst $ Map.findMax @loc.nmp) - nonts.flab = 0 - -ATTR Children Child [|| - fieldMap USE {Map.union} {Map.empty} : FMap - hoMap USE {Map.unionWith (Set.union)} {Map.empty} : HOMap - ] -SEM Children [ dty : {MyType} || ] - | Nil - loc.flab = @lhs.flab + 1 - loc.atp = fst @lhs.pll - inst.fatts : FieldAtts - inst.fatts = map ((FieldAtt @loc.atp @lhs.pll "lhs") . alab) $ - @lhs.an @loc.atp - fatts.flab = @loc.flab - loc.label = (@lhs.pll, "lhs") - loc.foccsI = Set.fromList $ handAllOut @loc.label $ @lhs.ain @loc.atp - loc.foccsS = Set.fromList $ handAllOut @loc.label $ @lhs.asn @loc.atp - loc.fieldMap= Map.singleton @loc.label (@loc.foccsI, @loc.foccsS) - lhs.fty = Map.singleton @loc.label @lhs.dty - -SEM Child | Child - loc.flab = @lhs.flab + 1 - loc.atp = toMyTy @tp - inst.fatts : FieldAtts - inst.fatts = map ((FieldAtt @loc.atp @lhs.pll (getName @name)) . alab) - $ @lhs.an @loc.atp - fatts.flab = @loc.flab - loc.ident = getName @name - loc.label = (@lhs.pll, @loc.ident) - loc.foccsI = Set.fromList $ handAllOut @loc.label $ @lhs.ain @loc.atp - loc.foccsS = Set.fromList $ handAllOut @loc.label $ @lhs.asn @loc.atp - loc.fieldMap= if Set.null @loc.foccsI && Set.null @loc.foccsS - then Map.empty - else Map.singleton @loc.label (@loc.foccsS,@loc.foccsI) - loc.hoMap = case @kind of - ChildAttr -> Map.singleton @lhs.pll (Set.singleton @loc.ident) - _ -> Map.empty - lhs.fty = Map.singleton (@lhs.pll, getName @name) @loc.atp - -SEM FieldAtt | FieldAtt - loc.olab = @lhs.olab + 1 - loc.alab = findWithErr @lhs.nmprf "getting attr label" @loc.att - loc.att = @t <.> @a - loc.occ = (@p, @f) >.< @a - loc.pmp = Map.singleton @loc.olab @loc.occ - loc.pmpr = Map.singleton @loc.occ @loc.olab - loc.inss = Map.singleton @loc.alab [@loc.olab] - loc.gen = Map.singleton @loc.olab @loc.alab - lhs.ap = Map.singleton @p [@loc.occ] - lhs.ofld = [(@loc.olab, @lhs.flab)] - --- calculate representation of semantic function --- definitions per non-terminal and from it, calculate E_P -SEM Grammar | Grammar - loc.sfp = repLocRefs @nonts.lfp $ addHigherOrders @nonts.lfp @nonts.sfp -ATTR Nonterminals Nonterminal Productions Production Rules Rule [ || - sfp USE {Map.unionWith (Set.union)} {Map.empty} : SF_P -- deps of non-locals - ruleMap USE {Map.union} {Map.empty} : {Map.Map MyOccurrence Identifier} - lfp USE {Map.unionWith (Set.union)} {Map.empty} : SF_P -- deps of local attrs - lfpr USE {Map.unionWith (Set.union)} {Map.empty} : SF_P ]-- reverse -SEM Production | Production - loc.pll = (@lhs.dty,getName @con) - rules.pll = @pll - rules.pts = @children.pts - lhs.fsInP = Map.singleton @pll $ Map.keys @children.fieldMap - -ATTR Children Child [ || - pts USE {Set.union} {Set.empty} : {Set.Set FLabel} ] - -SEM Child | Child - lhs.pts = Set.singleton $ getName @name - -ATTR Rules Rule [ - lfpf : SF_P || - usedLocals USE {(Set.union)} {Set.empty} : {Set.Set MyOccurrence}] - -SEM Rule | Rule - loc.usedLocals = Set.filter (\(MyOccurrence (_,f) _) -> f == "loc") @rhs.used - loc.usesLocals = not $ Set.null @loc.usedLocals - (lhs.sfp,lhs.ruleMap,lhs.lfp,lhs.lfpr) = - foldr (\(f, a, b) (m',rm', l', lr') -> - let att = (@lhs.pll, f) >.< a - rm = Map.insert att @rulename rm' - l = if @loc.usesLocals && not b - then Map.insert att @loc.usedLocals l' - else l' - lr = if @loc.usesLocals && not b - then Set.fold (\k m -> Map.insertWith (Set.union) k - (Set.singleton att) m) lr' @loc.usedLocals - else lr' - sfpins = Map.insert att (@rhs.used `Set.union` fromHO) m' - fromHO = maybe Set.empty id (Map.lookup hOcc @lhs.lfpf) - where hOcc = (@lhs.pll, "inst") >.< (f, AnyDir) - - in if b - then (m',rm, Map.insert att @rhs.used l, - Set.fold (\k m -> Map.insertWith (Set.union) k - (Set.singleton att) m) lr @rhs.used) - else (sfpins,rm,l,lr)) - (Map.empty,Map.empty,Map.empty,Map.empty) @pattern.afs - -ATTR Patterns Pattern [ || - -- the boolean represents whether this occurrence is - -- an transparent occurrence (only there to pass on dependencies) - afs USE {++} {[]} : {[(FLabel, ALabel, Bool)]} ] - -SEM Pattern | Alias - lhs.afs = let isLocal = (@field == _LOC || @field == _INST) - in [(getName @field, (getName @attr, dlhs @field), - isLocal)] ++ @pat.afs - -ATTR Rules Rule Expression HsTokensRoot HsTokens HsToken [ - -- the terminals of current production - pts : {Set.Set (FLabel)} || ] - -ATTR Rule Expression HsTokensRoot HsTokens HsToken [ || - used USE {Set.union} {Set.empty} : {Set.Set MyOccurrence} ] - -SEM Expression | Expression - inst.tokens : HsTokensRoot - inst.tokens = HsTokensRoot @tks - tokens.pll = @lhs.pll - tokens.pts = @lhs.pts - lhs.used = @tokens.used - --- reference to terminals of which some are local attributes -SEM HsToken | AGLocal - lhs.used = - case getName @var `Set.member` @lhs.pts of - True -> Set.empty - -- local found without flabel - False -> Set.singleton $ (@lhs.pll, getName _LOC) >.< - (getName @var, drhs _LOC) --- includes both locals and attributes --- locals will be replaced later by repLocRefs -SEM HsToken | AGField - lhs.used = Set.singleton $ (@lhs.pll, getName @field) >.< - (getName @attr, drhs @field) - -{ --- | Replace the references to local attributes, by his attrs dependencies, --- | rendering the local attributes 'transparent'. -repLocRefs :: SF_P -> SF_P -> SF_P -repLocRefs lfp sfp = - Map.map (setConcatMap $ rep Set.empty) sfp - where rep :: Set.Set MyOccurrence -> MyOccurrence -> Set.Set MyOccurrence - rep done occ | occ `Set.member` done = Set.empty - | isLoc occ = setConcatMap (rep $ Set.insert occ done) $ - findWithErr lfp "repping locals" occ - | otherwise = Set.singleton occ - --- | Add dependencies from a higher order child to all its attributes -addHigherOrders :: SF_P -> SF_P -> SF_P -addHigherOrders lfp sfp = - Map.mapWithKey f $ Map.map (setConcatMap (\mo -> f mo (Set.singleton mo))) sfp - where f :: MyOccurrence -> Set.Set MyOccurrence -> Set.Set MyOccurrence - f mo@(MyOccurrence (p,f) _) deps = - let ho = ((p,"inst") >.< (f,AnyDir)) - in if ho `Map.member` lfp - then ho `Set.insert` deps - else deps -} - - +INCLUDE "AbstractSyntax.ag" +INCLUDE "Patterns.ag" +INCLUDE "CodeSyntax.ag" +INCLUDE "Expression.ag" +INCLUDE "HsToken.ag" +INCLUDE "LOAG/Rep" +INCLUDE "ExecutionPlanPre" + +MODULE {LOAG.Prepare} +{} +{} + +{ +-- | Translating UUAGC types to MyTypes +drhs f | f == _LHS = Inh + | f == _LOC = AnyDir + | f == _INST = AnyDir + | otherwise = Syn +dlhs f | f == _LHS = Syn + | f == _LOC = AnyDir + | f == _INST = AnyDir + | otherwise = Inh + +depToEdge :: PMP_R -> PLabel -> Dependency -> Edge +depToEdge pmpr p e = + (findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f1) (getName i1, drhs f1), + findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f2) (getName i2, dlhs f2)) + where Dependency (OccAttr f1 i1) (OccAttr f2 i2) = e + +vertexToAttr :: NMP -> Vertex -> Attributes +vertexToAttr nmp v = Map.singleton (identifier a) (fromMyTy ty) + where (MyAttribute ty (a,_)) = findWithErr nmp "vertexToAttr" v + +} + +SEM Grammar | Grammar + inst.smf : LOAGRep + loc.initO= if Map.null @nonts.pmp then 1 else fst $ Map.findMin @nonts.pmp + inst.smf = + LOAGRep @nonts.ps @nonts.ap @loc.an + @loc.ain @loc.asn @loc.sfp + @nonts.pmp @nonts.pmpr @loc.nmp @loc.nmpr + (A.array (@loc.initO, @loc.initO + Map.size @nonts.gen) $ + Map.toList $ @nonts.gen) + (A.array (1,Map.size @nonts.inss) $ + Map.toList $ @nonts.inss) + (A.array (@loc.initO, @loc.initO + length @nonts.ofld) $ + @nonts.ofld) @nonts.fty @nonts.fieldMap @nonts.fsInP + loc.nmp = Map.fromList $ zip [1..] @loc.atts + loc.nmpr = Map.fromList $ zip @loc.atts [1..] + loc.an = Map.unionWith (++) @loc.ain @loc.asn + loc.ain = @nonts.inhs + loc.asn = @nonts.syns + loc.atts = concat $ Map.elems @loc.an + loc.occs = concat $ Map.elems @nonts.ap + nonts.augM = @manualAttrOrderMap + +-- Collecting the attributes +ATTR Nonterminals Nonterminal [ + augM : {Map.Map Identifier (Map.Map Identifier (Set.Set Dependency))} || + inhs USE {Map.union} {Map.empty} : AI_N + syns USE {Map.union} {Map.empty} : AS_N ] + +SEM Nonterminal | Nonterminal + lhs.inhs = let dty = TyData (getName @nt) + in Map.singleton dty (toMyAttr Inh dty @inh) + lhs.syns = let dty = TyData (getName @nt) + in Map.singleton dty (toMyAttr Syn dty @syn) + prods.augM = case Map.lookup @nt @lhs.augM of + Nothing -> Map.empty + Just a -> a + +-- Adding all attribute sets to the AG type +-- and sending it all down the abstract tree +ATTR Nonterminals Nonterminal Productions Production Children Child + MySegments MySegment [ + ain : {MyType -> MyAttributes} + asn : {MyType -> MyAttributes} + pmpf : PMP + pmprf : PMP_R + lfpf : SF_P + hoMapf: HOMap + fty : FTY + nmp : NMP || ] + +SEM Grammar | Grammar + nonts.ain = map2F @loc.ain + nonts.asn = map2F @loc.asn + nonts.pmpf = @nonts.pmp + nonts.pmprf = @nonts.pmpr + nonts.lfpf = @nonts.lfp + nonts.hoMapf= @nonts.hoMap + nonts.ftyf = @nonts.fty + nonts.fty = @nonts.fty + +-- Make sure TDP AND LFPRF are passed around correctly to code-generation +ATTR Nonterminals Nonterminal Productions Production [ + ftyf: FTY ||] + + +-- Calculate the set of production labels +SEM Grammar | Grammar + loc.ps = @nonts.ps +ATTR Nonterminals Nonterminal Productions Production [ || + ads USE {(++)} {[]} : {[Edge]} + fieldMap USE {(Map.union)} {Map.empty} : FMap + hoMap USE {(Map.union)} {Map.empty} : HOMap + fsInP USE {(Map.union)} {Map.empty} : FsInP] + +SEM Nonterminals Nonterminal [ || + ps USE {(++)} {([])} : {[PLabel]} ] +SEM Productions [ || + ps USE {:} {([])} : {[PLabel]} ] +SEM Production [ || ps : PLabel ] | Production + loc.ps = (@lhs.dty,getName @con) + lhs.ads = + case Map.lookup @con @lhs.augM of + Nothing -> [] + Just a -> Set.toList $ Set.map (depToEdge @children.pmpr @loc.pll) a + children.dty = @lhs.dty + +ATTR Productions Production [ + augM : {Map.Map Identifier (Set.Set Dependency)} || ] +-- We didnt calculate A_P yet, inheriting A_N we can +ATTR Productions Production Rules Rule [ + -- result type of this constructor + dty : {MyType} || ] +ATTR Rules Rule Children Child Expression HsTokensRoot HsTokens HsToken [ + pll : {PLabel} || ] +SEM Nonterminal | Nonterminal + loc.dty = TyData (getName @nt) + +ATTR Nonterminals Nonterminal Productions Production Children Child + FieldAtts FieldAtt [ + an : {MyType -> MyAttributes} + nmprf : NMP_R| + olab : Int -- chained attribute for handing out labels to occurrences + flab : Int |--chained attribute for handing out labels to fields + ap USE {Map.unionWith (++)} {Map.empty} : A_P + gen USE {Map.union} {Map.empty} : {Map Int Int} + inss USE {Map.unionWith (++)} {Map.empty} : {Map Int [Int]} + pmp USE {Map.union} {Map.empty} : PMP + pmpr USE {Map.union} {Map.empty} : PMP_R + -- maps for each occurrence to which field it belongs + ofld USE {(++)} {[]} : {[(Int, Int)]} + fty USE {Map.union} {Map.empty} : FTY + ] + +SEM Grammar | Grammar + nonts.an = map2F @loc.an + nonts.nmprf= @loc.nmpr + nonts.olab = if Map.null @loc.nmp then 0 else (fst $ Map.findMax @loc.nmp) + nonts.flab = 0 + +ATTR Children Child [|| + fieldMap USE {Map.union} {Map.empty} : FMap + hoMap USE {Map.unionWith (Set.union)} {Map.empty} : HOMap + ] +SEM Children [ dty : {MyType} || ] + | Nil + loc.flab = @lhs.flab + 1 + loc.atp = fst @lhs.pll + inst.fatts : FieldAtts + inst.fatts = map ((FieldAtt @loc.atp @lhs.pll "lhs") . alab) $ + @lhs.an @loc.atp + fatts.flab = @loc.flab + loc.label = (@lhs.pll, "lhs") + loc.foccsI = Set.fromList $ handAllOut @loc.label $ @lhs.ain @loc.atp + loc.foccsS = Set.fromList $ handAllOut @loc.label $ @lhs.asn @loc.atp + loc.fieldMap= Map.singleton @loc.label (@loc.foccsI, @loc.foccsS) + lhs.fty = Map.singleton @loc.label @lhs.dty + +SEM Child | Child + loc.flab = @lhs.flab + 1 + loc.atp = toMyTy @tp + inst.fatts : FieldAtts + inst.fatts = map ((FieldAtt @loc.atp @lhs.pll (getName @name)) . alab) + $ @lhs.an @loc.atp + fatts.flab = @loc.flab + loc.ident = getName @name + loc.label = (@lhs.pll, @loc.ident) + loc.foccsI = Set.fromList $ handAllOut @loc.label $ @lhs.ain @loc.atp + loc.foccsS = Set.fromList $ handAllOut @loc.label $ @lhs.asn @loc.atp + loc.fieldMap= if Set.null @loc.foccsI && Set.null @loc.foccsS + then Map.empty + else Map.singleton @loc.label (@loc.foccsS,@loc.foccsI) + loc.hoMap = case @kind of + ChildAttr -> Map.singleton @lhs.pll (Set.singleton @loc.ident) + _ -> Map.empty + lhs.fty = Map.singleton (@lhs.pll, getName @name) @loc.atp + +SEM FieldAtt | FieldAtt + loc.olab = @lhs.olab + 1 + loc.alab = findWithErr @lhs.nmprf "getting attr label" @loc.att + loc.att = @t <.> @a + loc.occ = (@p, @f) >.< @a + loc.pmp = Map.singleton @loc.olab @loc.occ + loc.pmpr = Map.singleton @loc.occ @loc.olab + loc.inss = Map.singleton @loc.alab [@loc.olab] + loc.gen = Map.singleton @loc.olab @loc.alab + lhs.ap = Map.singleton @p [@loc.occ] + lhs.ofld = [(@loc.olab, @lhs.flab)] + +-- calculate representation of semantic function +-- definitions per non-terminal and from it, calculate E_P +SEM Grammar | Grammar + loc.sfp = repLocRefs @nonts.lfp $ addHigherOrders @nonts.lfp @nonts.sfp +ATTR Nonterminals Nonterminal Productions Production Rules Rule [ || + sfp USE {Map.unionWith (Set.union)} {Map.empty} : SF_P -- deps of non-locals + ruleMap USE {Map.union} {Map.empty} : {Map.Map MyOccurrence Identifier} + lfp USE {Map.unionWith (Set.union)} {Map.empty} : SF_P -- deps of local attrs + lfpr USE {Map.unionWith (Set.union)} {Map.empty} : SF_P ]-- reverse +SEM Production | Production + loc.pll = (@lhs.dty,getName @con) + rules.pll = @pll + rules.pts = @children.pts + lhs.fsInP = Map.singleton @pll $ Map.keys @children.fieldMap + +ATTR Children Child [ || + pts USE {Set.union} {Set.empty} : {Set.Set FLabel} ] + +SEM Child | Child + lhs.pts = Set.singleton $ getName @name + +ATTR Rules Rule [ + lfpf : SF_P || + usedLocals USE {(Set.union)} {Set.empty} : {Set.Set MyOccurrence}] + +SEM Rule | Rule + loc.usedLocals = Set.filter (\(MyOccurrence (_,f) _) -> f == "loc") @rhs.used + loc.usesLocals = not $ Set.null @loc.usedLocals + (lhs.sfp,lhs.ruleMap,lhs.lfp,lhs.lfpr) = + foldr (\(f, a, b) (m',rm', l', lr') -> + let att = (@lhs.pll, f) >.< a + rm = Map.insert att @rulename rm' + l = if @loc.usesLocals && not b + then Map.insert att @loc.usedLocals l' + else l' + lr = if @loc.usesLocals && not b + then Set.fold (\k m -> Map.insertWith (Set.union) k + (Set.singleton att) m) lr' @loc.usedLocals + else lr' + sfpins = Map.insert att (@rhs.used `Set.union` fromHO) m' + fromHO = maybe Set.empty id (Map.lookup hOcc @lhs.lfpf) + where hOcc = (@lhs.pll, "inst") >.< (f, AnyDir) + + in if b + then (m',rm, Map.insert att @rhs.used l, + Set.fold (\k m -> Map.insertWith (Set.union) k + (Set.singleton att) m) lr @rhs.used) + else (sfpins,rm,l,lr)) + (Map.empty,Map.empty,Map.empty,Map.empty) @pattern.afs + +ATTR Patterns Pattern [ || + -- the boolean represents whether this occurrence is + -- an transparent occurrence (only there to pass on dependencies) + afs USE {++} {[]} : {[(FLabel, ALabel, Bool)]} ] + +SEM Pattern | Alias + lhs.afs = let isLocal = (@field == _LOC || @field == _INST) + in [(getName @field, (getName @attr, dlhs @field), + isLocal)] ++ @pat.afs + +ATTR Rules Rule Expression HsTokensRoot HsTokens HsToken [ + -- the terminals of current production + pts : {Set.Set (FLabel)} || ] + +ATTR Rule Expression HsTokensRoot HsTokens HsToken [ || + used USE {Set.union} {Set.empty} : {Set.Set MyOccurrence} ] + +SEM Expression | Expression + inst.tokens : HsTokensRoot + inst.tokens = HsTokensRoot @tks + tokens.pll = @lhs.pll + tokens.pts = @lhs.pts + lhs.used = @tokens.used + +-- reference to terminals of which some are local attributes +SEM HsToken | AGLocal + lhs.used = + case getName @var `Set.member` @lhs.pts of + True -> Set.empty + -- local found without flabel + False -> Set.singleton $ (@lhs.pll, getName _LOC) >.< + (getName @var, drhs _LOC) +-- includes both locals and attributes +-- locals will be replaced later by repLocRefs +SEM HsToken | AGField + lhs.used = Set.singleton $ (@lhs.pll, getName @field) >.< + (getName @attr, drhs @field) + +{ +-- | Replace the references to local attributes, by his attrs dependencies, +-- | rendering the local attributes 'transparent'. +repLocRefs :: SF_P -> SF_P -> SF_P +repLocRefs lfp sfp = + Map.map (setConcatMap $ rep Set.empty) sfp + where rep :: Set.Set MyOccurrence -> MyOccurrence -> Set.Set MyOccurrence + rep done occ | occ `Set.member` done = Set.empty + | isLoc occ = setConcatMap (rep $ Set.insert occ done) $ + findWithErr lfp "repping locals" occ + | otherwise = Set.singleton occ + +-- | Add dependencies from a higher order child to all its attributes +addHigherOrders :: SF_P -> SF_P -> SF_P +addHigherOrders lfp sfp = + Map.mapWithKey f $ Map.map (setConcatMap (\mo -> f mo (Set.singleton mo))) sfp + where f :: MyOccurrence -> Set.Set MyOccurrence -> Set.Set MyOccurrence + f mo@(MyOccurrence (p,f) _) deps = + let ho = ((p,"inst") >.< (f,AnyDir)) + in if ho `Map.member` lfp + then ho `Set.insert` deps + else deps +} + + diff --git a/src-ag/LOAG/Rep.ag b/src-ag/LOAG/Rep.ag --- a/src-ag/LOAG/Rep.ag +++ b/src-ag/LOAG/Rep.ag @@ -1,49 +1,49 @@ -MODULE {LOAG.Rep} -{}{ -import CommonTypes -import AbstractSyntax -import LOAG.Common -import qualified Data.Array as A -import qualified Data.Map as Map -import qualified Data.Set as Set -} -imports{ -import Data.List (intercalate, foldl', nub) -import Data.Tuple (swap) -import Control.Arrow -} - -DATA LOAGRep | LOAGRep - ps : {[PLabel]} - ap : A_P - an : A_N - ain : AI_N - asn : AS_N - sfp : SF_P - pmp : PMP - pmpr : PMP_R - nmp : NMP - nmpr : NMP_R - gen : {A.Array Int Int} - inss : {A.Array Int [Int]} - ofld : {A.Array Int Int} - fty : FTY - fieldMap : FMap - fsInP: {Map.Map PLabel [(PLabel,FLabel)]} - -TYPE FieldAtts = [FieldAtt] --- t is the type of the attribute this occurrence belongs to -DATA FieldAtt | FieldAtt t : {MyType} p : {PLabel} - f : {FLabel} a : {ALabel} - -TYPE MySegments = [MySegment] -DATA MySegment | MySegment - visnr : Int - inhAttr : {[Int]} - synAttr : {[Int]} - inhOccs : {Maybe [Int]} - synOccs : {Maybe [Int]} - -DERIVING MySegments MySegment : Show - - +MODULE {LOAG.Rep} +{}{ +import CommonTypes +import AbstractSyntax +import LOAG.Common +import qualified Data.Array as A +import qualified Data.Map as Map +import qualified Data.Set as Set +} +imports{ +import Data.List (intercalate, foldl', nub) +import Data.Tuple (swap) +import Control.Arrow +} + +DATA LOAGRep | LOAGRep + ps : {[PLabel]} + ap : A_P + an : A_N + ain : AI_N + asn : AS_N + sfp : SF_P + pmp : PMP + pmpr : PMP_R + nmp : NMP + nmpr : NMP_R + gen : {A.Array Int Int} + inss : {A.Array Int [Int]} + ofld : {A.Array Int Int} + fty : FTY + fieldMap : FMap + fsInP: {Map.Map PLabel [(PLabel,FLabel)]} + +TYPE FieldAtts = [FieldAtt] +-- t is the type of the attribute this occurrence belongs to +DATA FieldAtt | FieldAtt t : {MyType} p : {PLabel} + f : {FLabel} a : {ALabel} + +TYPE MySegments = [MySegment] +DATA MySegment | MySegment + visnr : Int + inhAttr : {[Int]} + synAttr : {[Int]} + inhOccs : {Maybe [Int]} + synOccs : {Maybe [Int]} + +DERIVING MySegments MySegment : Show + + diff --git a/src-ag/Macro.ag b/src-ag/Macro.ag --- a/src-ag/Macro.ag +++ b/src-ag/Macro.ag @@ -1,24 +1,24 @@ ---marcos: macros extension - -imports -{ -import CommonTypes -} - -TYPE MaybeMacro = MAYBE Macro - -DATA Macro | Macro con : {ConstructorIdent} - children : MacroChildren - | None - -TYPE MacroChildren = [MacroChild] - -DATA MacroChild | RuleChild name : {Identifier} - macro : Macro - | ChildChild name : {Identifier} - child : {Identifier} - - | ValueChild name : {Identifier} - value : {String} - -DERIVING MaybeMacro Macro MacroChildren MacroChild : Show +--marcos: macros extension + +imports +{ +import CommonTypes +} + +TYPE MaybeMacro = MAYBE Macro + +DATA Macro | Macro con : {ConstructorIdent} + children : MacroChildren + | None + +TYPE MacroChildren = [MacroChild] + +DATA MacroChild | RuleChild name : {Identifier} + macro : Macro + | ChildChild name : {Identifier} + child : {Identifier} + + | ValueChild name : {Identifier} + value : {String} + +DERIVING MaybeMacro Macro MacroChildren MacroChild : Show diff --git a/src-ag/Order.ag b/src-ag/Order.ag --- a/src-ag/Order.ag +++ b/src-ag/Order.ag @@ -1,809 +1,809 @@ -PRAGMA strictdata -PRAGMA strictwrap - -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "AbstractSyntax.ag" -INCLUDE "DistChildAttr.ag" - -imports -{ --- From uuagc -import CommonTypes -import Patterns -import ErrorMessages -import AbstractSyntax -import Code hiding (Type) -import qualified Code -import Expression -import Options -import SequentialComputation -import SequentialTypes -import CodeSyntax -import GrammarInfo -import HsToken(HsTokensRoot(HsTokensRoot)) -import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) --- From uulib -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Sequence as Seq -import Data.Map(Map) -import Data.Set(Set) -import Data.Sequence(Seq, (><)) -import UU.Util.Utils -import UU.Scanner.Position(Pos(..),initPos) -import Data.Foldable(toList) - --- From haskell libraries -import Control.Monad(liftM) -import qualified Data.Array as Array -import Data.Array((!),bounds,inRange) -import Data.List(elemIndex,partition,sort,mapAccumL,find,nubBy,intersperse,groupBy,transpose) -import qualified Data.Tree as Tree -import Data.Maybe -} - -{ --- Terminates with an error if the key is not in the map -findWithErr1 :: (Ord k, Show k) => String -> k -> Map k a -> a -findWithErr1 s k - = Map.findWithDefault (error ("findWithErr1 " ++ s ++ ": key " ++ show k ++ " not in map.")) k - -findWithErr2 :: (Ord k, Show k, Show a) => k -> Map k a -> a -findWithErr2 k m - = Map.findWithDefault (error ("findWithErr2: key " ++ show k ++ " not in map: " ++ show m)) k m -} - --- --- Some statistics, count number of attributes --- - -ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule [ | | nAutoRules,nExplicitRules USE {+} {0} : {Int} ] - -SEM Rule - | Rule lhs.nExplicitRules = if @explicit - then 1 - else 0 - lhs.nAutoRules = if startsWith "use rule" @origin || startsWith "copy rule" @origin - then 1 - else 0 - -{ -startsWith :: String -> String -> Bool -startsWith k h = k == take (length k) h -} - - -------------------------------------------------------------------------------- --- Errors -------------------------------------------------------------------------------- --- Everyone that wants to report an error can do this by adding an error message to the --- stream of errors - -ATTR Nonterminals Nonterminal Productions Production - Child Children Rule Rules Pattern Patterns Grammar [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ] - -------------------------------------------------------------------------------- --- Distributing name of nonterminal and names of attributes -------------------------------------------------------------------------------- -ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ] -ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ] - -SEM Production - | Production children . con = @con -SEM Production - | Production rules . con = @con -SEM Nonterminal - | Nonterminal prods . nt = @nt - -SEM Nonterminal - | Nonterminal prods.inh = @inh - prods.syn = @syn - - -------------------------------------------------------------------------------- --- Distributing options -------------------------------------------------------------------------------- - -ATTR Grammar [ options:{Options} | | ] -ATTR Nonterminals Nonterminal Productions Production Rules Rule - [ o_newtypes - , o_cata - , o_sig - , o_sem - , o_rename - , o_wantvisit -- True if the option for visit functions has been specified - , o_dovisit -- True if o_wantvisit and it is possible to generate visit functions (no cycles) - , o_case:{Bool} - prefix : {String} | | ] -ATTR Nonterminals Nonterminal Productions Production Children Child [ o_unbox:{Bool} | | ] -ATTR Nonterminals Nonterminal [ o_data:{Bool} | | ] - -SEM Grammar - | Grammar loc.o_dovisit = visit @lhs.options && null @cyclesErrors - nonts.o_cata = folds @lhs.options - .o_data = dataTypes @lhs.options - .o_sig = typeSigs @lhs.options - .o_sem = semfuns @lhs.options - .o_rename = rename @lhs.options - .o_newtypes= newtypes @lhs.options - .o_wantvisit = visit @lhs.options - .o_unbox = unbox @lhs.options - .o_case = cases @lhs.options - .prefix = prefix @lhs.options - ------------------------------------------------------------------- --- Building a mapping from Vertices to Ints ------------------------------------------------------------------- -{ -getNtName :: Type -> NontermIdent -getNtName (NT nt _ _) = nt -getNtName _ = nullIdent -} - ------------------------------------------------------------------- --- Collect attribute occurrences --- --- All attribute occurences in an alternative are gathered. --- This is done by joining various sublists: --- 1. inherited attributes for _LHS --- 2a. synthesized attributes for children --- 2b. children that are a trivial field --- 3a. inherited attributes for children --- 3b. synthesized attributes for _LHS --- 3c. local attributes --- --- Sublist 3 is exactly the targets for ATTR definitions, and --- thus can be obtained by traversing all rules. --- --- The (field,attr) combination is not enough to uniquely identify --- an attribute occurence, because threaded attributes occur twice. --- Therefore, in the AltAttr structures, a boolean is added, --- that is False in sublists 3a and 3b, i.e. the non-local output fields. --- --- Each AltAttr, that is eacht attribute occurence, is mapped to a number --- in the altAttrs Map, starting at vcount -{ -data AltAttr = AltAttr Identifier Identifier Bool - deriving (Eq, Ord, Show) -} -ATTR Rules Rule Production Productions Nonterminal Nonterminals - [ options : {Options} | | ] - -ATTR Children Child Rules Rule Patterns Pattern [ | | gathAltAttrs USE {++} {[]} : {[AltAttr]} ] -SEM Production - | Production loc.gathAltAttrs = [ AltAttr _LHS inh True | inh <- Map.keys @lhs.inh ] -- sublist 1 - ++ @children.gathAltAttrs -- sublist 2 - ++ @rules.gathAltAttrs -- sublist 3 - -SEM Child - | Child loc.maptolocal = case @tp of - NT nt _ _ -> Map.null @syn - _ -> True - lhs.gathAltAttrs = if @maptolocal - then [ AltAttr _LOC @name True ] -- sublist 2b - else [ AltAttr @name syn True | syn <- Map.keys @loc.syn ] -- sublist 2a -SEM Pattern - | Alias lhs.gathAltAttrs = [AltAttr @field @attr (@field == _LOC || @field == _INST)] -- sublist 3 - -ATTR Rules Rule Patterns Pattern [ altAttrs : {Map AltAttr Vertex} | | ] -SEM Production - | Production loc.altAttrs = Map.fromList (zip @gathAltAttrs [@lhs.vcount..]) - --- Information passed to Pattern -ATTR Children Child - [ | | nts USE {Seq.><} {Seq.empty} : {Seq (Identifier,NontermIdent)} - inhs USE {Seq.><} {Seq.empty} : {Seq (Identifier,Attributes)} ] -SEM Child - | Child lhs.nts = Seq.singleton (@name,getNtName @tp) - lhs.inhs = Seq.singleton (@name,@loc.inh) -ATTR Rules Rule - [ childNts : {Map Identifier NontermIdent} - childInhs : {Map Identifier Attributes} | | ] -SEM Production - | Production rules.childNts = Map.fromList (toList @children.nts) - rules.childInhs = Map.fromList (toList @children.inhs) - --- Collect CRules -ATTR Children Child Rules Rule - [ | | gathRules USE {Seq.><} {Seq.empty} : {Seq CRule} ] -SEM Production - | Production loc.inhRules = [ cRuleLhsInh inh @lhs.nt @con tp | (inh,tp) <- Map.assocs @lhs.inh ] - loc.gathRules = @inhRules ++ toList (@children.gathRules Seq.>< @rules.gathRules) - -SEM Child - | Child loc.gathRules = if @maptolocal - then Seq.singleton (cRuleTerminal @name @lhs.nt @lhs.con @tp) - else Seq.fromList [ cRuleRhsSyn syn @lhs.nt @lhs.con tp @name (getNtName @tp) | (syn,tp) <- Map.assocs @loc.syn] - -SEM Rule - | Rule loc.defines = let tp field attr | field == _LOC || field == _INST - = Map.lookup attr @lhs.allTypeSigs - | field == _LHS = Map.lookup attr @lhs.syn - | otherwise = Map.lookup attr (findWithErr1 "Rule.defines.tp" field @lhs.childInhs) - typ :: Pattern -> Maybe Type - typ (Alias field attr _) = tp field attr - typ (Underscore _) = Nothing - -- typ (Product _ pats) = tp _LOC undefined pats - typ _ = Nothing - - in Map.fromList [ (findWithErr1 "Rule.defines" aa @lhs.altAttrs, (field,attr,(tp field attr))) - | (field,attr,isLocalOrInst) <- @pattern.patternAttrs - , let aa = AltAttr field attr isLocalOrInst - ] - loc.gathRules = let childnt field = Map.lookup field @lhs.childNts - in Seq.fromList [ CRule attr False True @lhs.nt @lhs.con field (childnt field) tp @pattern.copy @rhs.textLines @defines @owrt @origin @rhs.allRhsVars @explicit @mbName - | (field,attr,tp) <- Map.elems @defines - ] - -{ -substSelf nt tp - = case tp of - NT n tps defor | n == _SELF -> NT nt tps defor - _ -> tp - -haskellTupel :: [Type] -> Maybe Type -haskellTupel ts = Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" )) -} - - -ATTR Patterns Pattern [ | | patternAttrs USE {++} {[]} : {[(Identifier,Identifier,Bool)]} ] - -SEM Pattern - | Alias lhs.patternAttrs = [(@field,@attr,(@field == _LOC || @field == _INST))] - - - --- Giving them a number -ATTR Nonterminals Nonterminal Productions Production - [ | vcount : Int - | rules USE {Seq.><} {Seq.empty} : {Seq (Vertex,CRule)}] -SEM Grammar - | Grammar nonts.vcount = 0 -SEM Production - | Production lhs.rules = Seq.fromList (zip [@lhs.vcount..] @gathRules) - lhs.vcount = @lhs.vcount + length @gathRules - --- Direct dependencies -ATTR Nonterminals Nonterminal - Productions Production - Rules Rule [ | | directDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] -SEM Rule - | Rule lhs.directDep - = let defined = Map.keys @defines - used = [ Map.lookup (AltAttr field attr True) @lhs.altAttrs | (field,attr) <- @rhs.usedAttrs] - ++ [ Map.lookup (AltAttr _LOC attr True) @lhs.altAttrs | attr <- @rhs.usedLocals ++ @rhs.usedFields ] - in Seq.fromList [ (x,y) | Just x <- used, y <- defined ] - --- Manual depdendencies (provided by the programmer) --- --- a dependency f1.a1 < f2.a2 is translated to --- the edge (vertex(f1.a1), vertex(f2.a2)) -ATTR Nonterminals Nonterminal - Productions Production - [ manualAttrDepMap : {AttrOrderMap} | | additionalDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] - -SEM Grammar - | Grammar - nonts.manualAttrDepMap = @manualAttrOrderMap - -SEM Production - | Production - loc.manualDeps - = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrDepMap - - lhs.additionalDep - = Seq.fromList [ (vertex True occA, vertex False occB) - | Dependency occA occB <- @loc.manualDeps - , let vertex inout (OccAttr child nm) - | child == _LOC = findWithErr2 (AltAttr _LOC nm True) @loc.altAttrs - | otherwise = findWithErr2 (AltAttr child nm inout) @loc.altAttrs - vertex _ (OccRule nm) - = findWithErr2 (AltAttr _LOC (Ident ("_rule_" ++ show nm) (getPos nm)) True) @loc.altAttrs - ] - --- Inst dependencies --- --- For each inst attribute x of nt N, add the dependency --- (inst.x,x.y) for each synthesized attribute of N --- - -ATTR Nonterminals Nonterminal - Productions Production - Rules Rule [ | | instDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] -SEM Rule - | Rule - loc.instDep1 - = Seq.fromList $ - [ (instVert, synVert) - | (field,instNm,_) <- Map.elems @defines - , field == _INST - , synNm <- Map.keys (findWithErr2 instNm @lhs.synsOfChildren) - , let instAttr = AltAttr _INST instNm True - synAttr = AltAttr instNm synNm True - instVert = findWithErr2 instAttr @lhs.altAttrs - synVert = findWithErr2 synAttr @lhs.altAttrs - ] - loc.instDep2 - = Seq.fromList $ - [ (instVert, inhVert) - | (field,instNm,_) <- Map.elems @defines - , field == _INST - , inhNm <- Map.keys (findWithErr2 instNm @lhs.inhsOfChildren) - , let instAttr = AltAttr _INST instNm True - inhAttr = AltAttr instNm inhNm False - instVert = findWithErr2 instAttr @lhs.altAttrs - inhVert = findWithErr2 inhAttr @lhs.altAttrs - ] - lhs.instDep = @loc.instDep1 Seq.>< @loc.instDep2 - -ATTR Rules Rule [ synsOfChildren, inhsOfChildren : {Map Identifier Attributes} | | ] -SEM Production - | Production rules.synsOfChildren = @children.collectChildrenSyns - rules.inhsOfChildren = @children.collectChildrenInhs - -ATTR Children Child [ | | collectChildrenSyns, collectChildrenInhs USE {`Map.union`} {Map.empty} : {Map Identifier Attributes } ] -SEM Child - | Child lhs.collectChildrenSyns = Map.singleton @name @loc.syn - lhs.collectChildrenInhs = Map.singleton @name @loc.inh - --- --- Merge stuff --- - -ATTR Nonterminals Nonterminal - [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ] - -ATTR Productions Production - [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))} | | ] - -SEM Nonterminal | Nonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap -SEM Production | Production loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap - -ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ] - --- for a child c : N, with merged children cs, add dependencies between synthesized attrs of --- c to synthesized attrs of cs, and to the merge-attribute -ATTR Nonterminals Nonterminal Productions Production - [ | | mergeDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] - -SEM Production - | Production - lhs.mergeDep = @loc.mergeDep1 Seq.>< @loc.mergeDep2 - loc.mergeDep1 - = Seq.fromList $ - [ (childVert, synVert) - | childNm <- Map.keys @loc.mergeMap - , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns) - , let childNm' = Ident (show childNm ++ "_merge") (getPos childNm) - childAttr = AltAttr _LOC childNm' True - synAttr = AltAttr childNm synNm True - childVert = findWithErr2 childAttr @loc.altAttrs - synVert = findWithErr2 synAttr @loc.altAttrs - ] - loc.mergeDep2 - = Seq.fromList $ - [ (mergedVert, sourceVert) - | (childNm, (_,cs)) <- Map.assocs @loc.mergeMap - , c <- cs - , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns) - , let sourceAttr = AltAttr childNm synNm True - mergedAttr = AltAttr c synNm True - sourceVert = findWithErr2 sourceAttr @loc.altAttrs - mergedVert = findWithErr2 mergedAttr @loc.altAttrs - ] - - --- Around dependencies --- --- For each around x_around on x of nt N, add the dependency --- (x_around, x.y) for each synthesized attribute y of N --- - -ATTR Nonterminals Nonterminal - Productions Production - [ | | aroundDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] - -ATTR Nonterminals Nonterminal - [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ] - -ATTR Productions Production - [ aroundMap : {Map ConstructorIdent (Map Identifier [Expression])} || ] - -SEM Nonterminal | Nonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap -SEM Production | Production loc.aroundMap = Map.findWithDefault Map.empty @con @lhs.aroundMap - -SEM Grammar - | Grammar nonts.aroundMap = @aroundsMap - -SEM Production - | Production - loc.aroundDep1 - = Seq.fromList $ - [ (childVert, synVert) - | childNm <- Map.keys @loc.aroundMap - , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns) - , let childNm' = Ident (show childNm ++ "_around") (getPos childNm) - childAttr = AltAttr _LOC childNm' True - synAttr = AltAttr childNm synNm True - childVert = findWithErr2 childAttr @loc.altAttrs - synVert = findWithErr2 synAttr @loc.altAttrs - ] - loc.aroundDep2 - = Seq.fromList $ - [ (childVert, inhVert) - | childNm <- Map.keys @loc.aroundMap - , inhNm <- Map.keys (findWithErr2 childNm @children.collectChildrenInhs) - , let childNm' = Ident (show childNm ++ "_around") (getPos childNm) - childAttr = AltAttr _LOC childNm' True - inhAttr = AltAttr childNm inhNm False - childVert = findWithErr2 childAttr @loc.altAttrs - inhVert = findWithErr2 inhAttr @loc.altAttrs - ] - lhs.aroundDep = @loc.aroundDep1 Seq.>< @loc.aroundDep2 - - --- Wrapping an Expression - -ATTR Expression [ nt,con :{Identifier} - allfields:{[(Identifier,Type,ChildKind)]} - allnts :{[Identifier]} - attrs :{[(Identifier,Identifier)]} - options :{Options} - || - errors :{Seq Error} - usedLocals:{[Identifier]} - usedAttrs :{[(Identifier,Identifier)]} - usedFields:{[Identifier]} - textLines :{[String]} - copy : SELF - allRhsVars : {Set (Identifier,Identifier)} - ] - --- appendum: filter out the syn attrs of merged children in the input attr list. --- add the merged children to the used attr list --- appendum: ignored the error reporting on expressions. These are already --- reported by the separate 'ResolveLocals' pass. -SEM Expression - | Expression loc.(textLines,usedAttrs,usedLocals,usedFields) - = let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ] - attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs - inherited = Inh_HsTokensRoot - { attrs_Inh_HsTokensRoot = attrsIn - , con_Inh_HsTokensRoot = @lhs.con - , allfields_Inh_HsTokensRoot = @lhs.allfields - , allnts_Inh_HsTokensRoot = @lhs.allnts - , nt_Inh_HsTokensRoot = @lhs.nt - , options_Inh_HsTokensRoot = @lhs.options - } - synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited - in case synthesized of - Syn_HsTokensRoot - { textLines_Syn_HsTokensRoot = textLines - , usedAttrs_Syn_HsTokensRoot = usedAttrs - , usedLocals_Syn_HsTokensRoot = usedLocals - , usedFields_Syn_HsTokensRoot = usedFields - } -> let extraAttrs = [ (src,attr) - | (fld,attr) <- usedAttrs, let mbMerged = Map.lookup fld @lhs.mergeMap, isJust mbMerged - , let (Just (_, srcs)) = mbMerged, src <- srcs ] - usedAttrs' = usedAttrs ++ extraAttrs - in (textLines,usedAttrs',usedLocals,usedFields) - - lhs.errors = Seq.empty - lhs.allRhsVars = Set.fromList @loc.usedAttrs - `Set.union` - Set.fromList [ (_LOC, l) | l <- @loc.usedLocals] - `Set.union` - Set.fromList [ (_FIELD, fld) | fld <- @loc.usedFields] - - -------------------------------------- --- NT-Attributes -------------------------------------- -ATTR Nonterminals Nonterminal - [ | acount : Int | ntattrs USE {Seq.><} {Seq.empty} : {Seq (Vertex,NTAttr)} - aranges USE {Seq.><} {Seq.empty} : {Seq (Int,Int,Int)}] - -SEM Grammar - | Grammar nonts.acount = 0 - -SEM Nonterminal - | Nonterminal loc.ntattrs = [ NTAInh @nt inh tp | (inh,tp) <- Map.assocs @inh ] - ++ [NTASyn @nt syn tp | (syn,tp) <- Map.assocs @syn ] - lhs.ntattrs = Seq.fromList (zip [@lhs.acount ..] @ntattrs) - lhs.acount = @lhs.acount + Map.size @inh + Map.size @syn - lhs.aranges = Seq.singleton - (@lhs.acount - ,@lhs.acount + Map.size @inh - ,@lhs.acount + Map.size @syn + Map.size @inh - 1) ------------------------------------------------------------------- --- Pass structure up ------------------------------------------------------------------- -ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ] -SEM Nonterminal - | Nonterminal lhs.nonts = [(@nt,@prods.cons)] -ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ] -SEM Production - | Production lhs.cons = [@con] - ------------------------------------------------------------------- --- Collect type signatures ------------------------------------------------------------------- -ATTR TypeSigs TypeSig [ | typeSigs : {Map Identifier Type} | ] -SEM Production - | Production typeSigs.typeSigs = Map.empty -SEM TypeSig - | TypeSig lhs.typeSigs = Map.insert @name @tp @lhs.typeSigs - -ATTR Rules Rule Patterns Pattern [ allTypeSigs : {Map Identifier Type} | | ] -SEM Production - | Production rules.allTypeSigs = @typeSigs.typeSigs - ------------------------------------------------------------------- --- Invoking sequential computation ------------------------------------------------------------------- -SEM Grammar - | Grammar loc.ruleTable = Array.array (0,@nonts.vcount-1) (toList @nonts.rules) - loc.attrTable = Array.array (0,@nonts.acount-1) (toList @nonts.ntattrs) - loc.attrVertex = Map.fromList (map swap (toList @nonts.ntattrs)) - loc.tdpToTds = [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v @attrVertex) (ntattr cr)) - | (s,cr) <- toList @nonts.rules] - loc.tdsToTdp = let eq (_,v) (_,v') = v == v' - conv ((s,v):svs) | v == -1 = Nothing - | otherwise = Just (v,s:map fst svs) - in mapMaybe conv (eqClasses eq @tdpToTds) - loc.directDep = toList (@nonts.directDep Seq.>< @nonts.additionalDep) - loc.instDep = toList @nonts.instDep - loc.aroundDep = toList @nonts.aroundDep - loc.mergeDep = toList @nonts.mergeDep - loc.info = let def [] = -1 - def (v:vs) = v - in Info { tdsToTdp = Array.array (0,@nonts.acount-1) @tdsToTdp - , tdpToTds = Array.array (0,@nonts.vcount-1) @tdpToTds - , attrTable = @attrTable - , ruleTable = @ruleTable - , lmh = toList @nonts.aranges - , nonts = @nonts.nonts - , wraps = @wrappers - } - - loc.(cInterfaceMap,cVisitsMap,cyclesErrors) = - case computeSequential @info @directDep (@instDep ++ @aroundDep ++ @loc.mergeDep) of - CycleFree cim cvm -> ( cim - , cvm - , [] - ) - LocalCycle errs -> ( error "No interfaces for AG with local cycles" - , error "No visit sub-sequences for AG with local cycles" - , map (localCycleErr @ruleTable (visit @lhs.options)) errs - ) - InstCycle errs -> ( error "No interfaces for AG with cycles through insts" - , error "No visit sub-sequences for AG with cycles through insts" - , map (instCycleErr @ruleTable (visit @lhs.options)) errs - ) - DirectCycle errs -> ( error "No interfaces for AG with direct cycles" - , error "No visit sub-sequences for AG with direct cycles" - , directCycleErrs @attrTable @ruleTable (visit @lhs.options) errs - ) - InducedCycle cim errs -> ( cim - , error "No visit sub-sequences for AG with induced cycles" - , inducedCycleErrs @attrTable @ruleTable cim errs - ) - lhs.errors = (if withCycle @lhs.options then Seq.fromList @cyclesErrors else Seq.empty) - Seq.>< @nonts.errors - ------------------------------------------------------------------- --- Generate CGrammar ------------------------------------------------------------------- --- Pass InterfaceMap down and select the Interface in the Nonterminal -ATTR Nonterminals Nonterminal [ cInterfaceMap : CInterfaceMap | | ] -SEM Nonterminal - | Nonterminal loc.cInter = if @lhs.o_dovisit - then findWithErr1 "Nonterminal.cInter" @nt @lhs.cInterfaceMap - else CInterface [CSegment @inh @syn] - --- Pass VisitMap down and select the CVisits in the Production -ATTR Nonterminals Nonterminal Productions Production [ cVisitsMap : CVisitsMap | | ] -SEM Production - | Production loc.cVisits = if @lhs.o_dovisit - then let prodsVisitsMap = findWithErr1 "Production.cVisits.nt" @lhs.nt @lhs.cVisitsMap - visits = findWithErr1 "Production.cVisits.con" @con prodsVisitsMap - in visits - else let vss = nubBy eqCRuleDefines @gathRules ++ @children.singlevisits - in [CVisit @lhs.inh @lhs.syn vss [] False] - --- Declarations for single visits -ATTR Child Children [ | | singlevisits USE {++} {[]}: {[CRule]}] -SEM Child - | Child lhs.singlevisits = if @maptolocal - then [] - else [CChildVisit @name (getNtName @tp) 0 @loc.inh @loc.syn True] - --- Now just build the CGrammar -SEM Grammar [ | | output : CGrammar ] - | Grammar lhs.output = CGrammar @typeSyns @derivings @wrappers @nonts.cNonterminals @pragmas @paramMap @contextMap @quantMap @loc.aroundMap @loc.mergeMap @loc.o_dovisit -SEM Nonterminals [ | | cNonterminals : CNonterminals ] - | Cons lhs.cNonterminals = @hd.cNonterminal : @tl.cNonterminals - | Nil lhs.cNonterminals = [] -SEM Nonterminal [ | | cNonterminal : CNonterminal ] - | Nonterminal lhs.cNonterminal = CNonterminal @nt @params @inh @syn @prods.cProductions @cInter -SEM Productions [ | | cProductions : CProductions ] - | Cons lhs.cProductions = @hd.cProduction : @tl.cProductions - | Nil lhs.cProductions = [] -SEM Production [ | | cProduction : CProduction ] - | Production lhs.cProduction = CProduction @con @cVisits @children.fields @children.terminals - -SEM Grammar - | Grammar loc.aroundMap = Map.map (Map.map Map.keysSet) @aroundsMap - loc.mergeMap = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap - --- Collect terminals -ATTR Children Child [ | | terminals USE {++} {[]} : {[Identifier]} ] -SEM Child - | Child lhs.terminals = if @maptolocal - then [@name] - else [] - - --- Collecting nts -ATTR Nonterminal Nonterminals - Production Productions - Rule Rules - Child Children [allnts:{[Identifier]} | | ] - -SEM Grammar - | Grammar nonts.allnts = map fst (@nonts.nonts) - --- Collecting fields -ATTR Rule Rules - Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ] - -SEM Production - | Production loc.allfields = @children.fields - .attrs = map ((,) _LOC) @rules.locVars ++ - map ((,) _INST) @rules.instVars ++ - map ((,) _LHS) @inhnames ++ - concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes] - .inhnames = Map.keys @lhs.inh - .synnames = Map.keys @lhs.syn - -ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ] -SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ] - | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)] - - -SEM Child [ | | field : {(Identifier,Type,ChildKind)} ] - | Child lhs.field = (@name, @tp, @kind) - -SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ] - | Cons lhs.fields = @hd.field : @tl.fields - | Nil lhs.fields = [] - -ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ] - -SEM Pattern - | Alias lhs.locVars = if @field == _LOC - then [@attr] - else [] - lhs.instVars = if @field == _INST - then [@attr] - else [] - -{ -swap (a,b) = (b,a) - -showPath :: Table CRule -> [Vertex] -> [String] -showPath ruleTable path - = let look a | inRange (bounds ruleTable) a = [showOrigin (ruleTable ! a)] - | otherwise = ["Vertex " ++ show a] - showOrigin cr | getHasCode cr && getName (getAttr cr) /= "self" = prettyCRule cr ++ " (" ++ show (getPos (getAttr cr)) ++ ")" - | otherwise = prettyCRule cr - in concatMap look path - - -showPathLocal :: Table CRule -> [Vertex] -> [String] -showPathLocal _ [] = [] -showPathLocal ruleTable xs = showP (xs++[-1]) - where showP [] = [] - showP (v1:v2:vs) = let line = step v1 v2 - lines = showP vs - in line:lines - step v1 v2 = " - " ++ a1 - where r1 = ruleTable ! v1 - a1 = show (getAttr r1) - - -limitTo :: Int -> [String] -> [String] -limitTo _ [] = [] -limitTo 0 _ = ["....etcetera, etcetera...."] -limitTo n (x:xs) = x : limitTo (n-1) xs - -showPathNice :: Table CRule -> [Vertex] -> [String] -showPathNice _ [] = [] -showPathNice ruleTable xs = limitTo 100 (showP ((-1):xs++[-1])) - where [maxf, maxa, maxn, maxc] = maxWidths ruleTable (take 100 xs) - showP [] = [] - showP (v1:v2:vs) = let line = step v1 v2 - lines = showP vs - in if null line then lines else line:lines - step v1 v2 | last && first = induced - | last && isSyn r1 = "pass up " ++ alignR maxf "" ++ " " ++ alignL maxa a1 ++ " in " ++ alignR maxn n1 ++ "|" ++ c1 ++ induced - | first&& not(isSyn r2) = "get from above " ++ alignR maxf "" ++ " " ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 - | last = "pass down " ++ alignR maxf f1 ++ "." ++ a1 ++ induced - | isSyn r2 = "get from below " ++ alignR maxf f2 ++ "." ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 - | isLocal r1 = if head a1 == '_' - then "" - else "calculate " ++ alignR maxf "loc" ++ "." ++ a1 - | otherwise = "pass down " ++ alignR maxf f1 ++ "." ++ alignL maxa a1 ++ " to " ++ alignR maxn n2 ++ "|" ++ c2 - where - first = v1<0 - last = v2<0 - r1 = ruleTable ! v1 - r2 = ruleTable ! v2 - a1 = show (getAttr r1) - a2 = show (getAttr r2) - f1 = show (getField r1) - f2 = show (getField r2) - n1 = show (getLhsNt r1) - n2 = show (getLhsNt r2) - c1 = show (getCon r1) - c2 = show (getCon r2) - induced | v2== -2 = " INDUCED dependency to " - | otherwise = "" - - -maxWidths ruleTable vs - = map maximum (transpose (map getWidth vs)) - where getWidth v | v<0 = [0,0,0,0] - | otherwise = map (length . show . ($ (ruleTable!v))) [getField, getAttr, getLhsNt, getCon] - -alignL n xs | k Bool -> Route -> Error -localCycleErr ruleTable o_visit (s:path) - = let cr = ruleTable ! s - attr = getAttr cr - nt = getLhsNt cr - con = getCon cr - in LocalCirc nt con attr o_visit (showPathLocal ruleTable path) - -instCycleErr :: Table CRule -> Bool -> Route -> Error -instCycleErr ruleTable o_visit (s:path) - = let cr = ruleTable ! s - attr = getAttr cr - nt = getLhsNt cr - con = getCon cr - in InstCirc nt con attr o_visit (showPathLocal ruleTable path) - -directCycleErrs :: Table NTAttr -> Table CRule -> Bool -> [EdgeRoutes] -> [Error] -directCycleErrs attrTable ruleTable o_visit xs - = let getNont v = case attrTable ! v of - NTASyn nt _ _ -> nt - NTAInh nt _ _ -> nt - getAttr v = case attrTable ! v of - NTASyn _ a _ -> a - NTAInh _ a _ -> a - sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 - procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) - wrapGroup gr@(((v1,_),_,_):_) = DirectCirc (getNont v1) o_visit (map procCycle gr) - in map wrapGroup (groupBy sameNont xs) - -inducedCycleErrs :: Table NTAttr -> Table CRule -> CInterfaceMap -> [EdgeRoutes] -> [Error] -inducedCycleErrs attrTable ruleTable cim xs - = let getNont v = case attrTable ! v of - NTASyn nt _ _ -> nt - NTAInh nt _ _ -> nt - getAttr v = case attrTable ! v of - NTASyn _ a _ -> a - NTAInh _ a _ -> a - sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 - procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) - wrapGroup gr@(((v1,_),_,_):_) = InducedCirc (getNont v1) (findWithErr1 "inducedCycleErr.cinter" (getNont v1) cim) (map procCycle gr) - in map wrapGroup (groupBy sameNont xs) -} +PRAGMA strictdata +PRAGMA strictwrap + +INCLUDE "Patterns.ag" +INCLUDE "Expression.ag" +INCLUDE "AbstractSyntax.ag" +INCLUDE "DistChildAttr.ag" + +imports +{ +-- From uuagc +import CommonTypes +import Patterns +import ErrorMessages +import AbstractSyntax +import Code hiding (Type) +import qualified Code +import Expression +import Options +import SequentialComputation +import SequentialTypes +import CodeSyntax +import GrammarInfo +import HsToken(HsTokensRoot(HsTokensRoot)) +import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) +-- From uulib +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Sequence as Seq +import Data.Map(Map) +import Data.Set(Set) +import Data.Sequence(Seq, (><)) +import UU.Util.Utils +import UU.Scanner.Position(Pos(..),initPos) +import Data.Foldable(toList) + +-- From haskell libraries +import Control.Monad(liftM) +import qualified Data.Array as Array +import Data.Array((!),bounds,inRange) +import Data.List(elemIndex,partition,sort,mapAccumL,find,nubBy,intersperse,groupBy,transpose) +import qualified Data.Tree as Tree +import Data.Maybe +} + +{ +-- Terminates with an error if the key is not in the map +findWithErr1 :: (Ord k, Show k) => String -> k -> Map k a -> a +findWithErr1 s k + = Map.findWithDefault (error ("findWithErr1 " ++ s ++ ": key " ++ show k ++ " not in map.")) k + +findWithErr2 :: (Ord k, Show k, Show a) => k -> Map k a -> a +findWithErr2 k m + = Map.findWithDefault (error ("findWithErr2: key " ++ show k ++ " not in map: " ++ show m)) k m +} + +-- +-- Some statistics, count number of attributes +-- + +ATTR Grammar Nonterminals Nonterminal Productions Production Rules Rule [ | | nAutoRules,nExplicitRules USE {+} {0} : {Int} ] + +SEM Rule + | Rule lhs.nExplicitRules = if @explicit + then 1 + else 0 + lhs.nAutoRules = if startsWith "use rule" @origin || startsWith "copy rule" @origin + then 1 + else 0 + +{ +startsWith :: String -> String -> Bool +startsWith k h = k == take (length k) h +} + + +------------------------------------------------------------------------------- +-- Errors +------------------------------------------------------------------------------- +-- Everyone that wants to report an error can do this by adding an error message to the +-- stream of errors + +ATTR Nonterminals Nonterminal Productions Production + Child Children Rule Rules Pattern Patterns Grammar [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ] + +------------------------------------------------------------------------------- +-- Distributing name of nonterminal and names of attributes +------------------------------------------------------------------------------- +ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ] +ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ] + +SEM Production + | Production children . con = @con +SEM Production + | Production rules . con = @con +SEM Nonterminal + | Nonterminal prods . nt = @nt + +SEM Nonterminal + | Nonterminal prods.inh = @inh + prods.syn = @syn + + +------------------------------------------------------------------------------- +-- Distributing options +------------------------------------------------------------------------------- + +ATTR Grammar [ options:{Options} | | ] +ATTR Nonterminals Nonterminal Productions Production Rules Rule + [ o_newtypes + , o_cata + , o_sig + , o_sem + , o_rename + , o_wantvisit -- True if the option for visit functions has been specified + , o_dovisit -- True if o_wantvisit and it is possible to generate visit functions (no cycles) + , o_case:{Bool} + prefix : {String} | | ] +ATTR Nonterminals Nonterminal Productions Production Children Child [ o_unbox:{Bool} | | ] +ATTR Nonterminals Nonterminal [ o_data:{Bool} | | ] + +SEM Grammar + | Grammar loc.o_dovisit = visit @lhs.options && null @cyclesErrors + nonts.o_cata = folds @lhs.options + .o_data = dataTypes @lhs.options + .o_sig = typeSigs @lhs.options + .o_sem = semfuns @lhs.options + .o_rename = rename @lhs.options + .o_newtypes= newtypes @lhs.options + .o_wantvisit = visit @lhs.options + .o_unbox = unbox @lhs.options + .o_case = cases @lhs.options + .prefix = prefix @lhs.options + +------------------------------------------------------------------ +-- Building a mapping from Vertices to Ints +------------------------------------------------------------------ +{ +getNtName :: Type -> NontermIdent +getNtName (NT nt _ _) = nt +getNtName _ = nullIdent +} + +------------------------------------------------------------------ +-- Collect attribute occurrences +-- +-- All attribute occurences in an alternative are gathered. +-- This is done by joining various sublists: +-- 1. inherited attributes for _LHS +-- 2a. synthesized attributes for children +-- 2b. children that are a trivial field +-- 3a. inherited attributes for children +-- 3b. synthesized attributes for _LHS +-- 3c. local attributes +-- +-- Sublist 3 is exactly the targets for ATTR definitions, and +-- thus can be obtained by traversing all rules. +-- +-- The (field,attr) combination is not enough to uniquely identify +-- an attribute occurence, because threaded attributes occur twice. +-- Therefore, in the AltAttr structures, a boolean is added, +-- that is False in sublists 3a and 3b, i.e. the non-local output fields. +-- +-- Each AltAttr, that is eacht attribute occurence, is mapped to a number +-- in the altAttrs Map, starting at vcount +{ +data AltAttr = AltAttr Identifier Identifier Bool + deriving (Eq, Ord, Show) +} +ATTR Rules Rule Production Productions Nonterminal Nonterminals + [ options : {Options} | | ] + +ATTR Children Child Rules Rule Patterns Pattern [ | | gathAltAttrs USE {++} {[]} : {[AltAttr]} ] +SEM Production + | Production loc.gathAltAttrs = [ AltAttr _LHS inh True | inh <- Map.keys @lhs.inh ] -- sublist 1 + ++ @children.gathAltAttrs -- sublist 2 + ++ @rules.gathAltAttrs -- sublist 3 + +SEM Child + | Child loc.maptolocal = case @tp of + NT nt _ _ -> Map.null @syn + _ -> True + lhs.gathAltAttrs = if @maptolocal + then [ AltAttr _LOC @name True ] -- sublist 2b + else [ AltAttr @name syn True | syn <- Map.keys @loc.syn ] -- sublist 2a +SEM Pattern + | Alias lhs.gathAltAttrs = [AltAttr @field @attr (@field == _LOC || @field == _INST)] -- sublist 3 + +ATTR Rules Rule Patterns Pattern [ altAttrs : {Map AltAttr Vertex} | | ] +SEM Production + | Production loc.altAttrs = Map.fromList (zip @gathAltAttrs [@lhs.vcount..]) + +-- Information passed to Pattern +ATTR Children Child + [ | | nts USE {Seq.><} {Seq.empty} : {Seq (Identifier,NontermIdent)} + inhs USE {Seq.><} {Seq.empty} : {Seq (Identifier,Attributes)} ] +SEM Child + | Child lhs.nts = Seq.singleton (@name,getNtName @tp) + lhs.inhs = Seq.singleton (@name,@loc.inh) +ATTR Rules Rule + [ childNts : {Map Identifier NontermIdent} + childInhs : {Map Identifier Attributes} | | ] +SEM Production + | Production rules.childNts = Map.fromList (toList @children.nts) + rules.childInhs = Map.fromList (toList @children.inhs) + +-- Collect CRules +ATTR Children Child Rules Rule + [ | | gathRules USE {Seq.><} {Seq.empty} : {Seq CRule} ] +SEM Production + | Production loc.inhRules = [ cRuleLhsInh inh @lhs.nt @con tp | (inh,tp) <- Map.assocs @lhs.inh ] + loc.gathRules = @inhRules ++ toList (@children.gathRules Seq.>< @rules.gathRules) + +SEM Child + | Child loc.gathRules = if @maptolocal + then Seq.singleton (cRuleTerminal @name @lhs.nt @lhs.con @tp) + else Seq.fromList [ cRuleRhsSyn syn @lhs.nt @lhs.con tp @name (getNtName @tp) | (syn,tp) <- Map.assocs @loc.syn] + +SEM Rule + | Rule loc.defines = let tp field attr | field == _LOC || field == _INST + = Map.lookup attr @lhs.allTypeSigs + | field == _LHS = Map.lookup attr @lhs.syn + | otherwise = Map.lookup attr (findWithErr1 "Rule.defines.tp" field @lhs.childInhs) + typ :: Pattern -> Maybe Type + typ (Alias field attr _) = tp field attr + typ (Underscore _) = Nothing + -- typ (Product _ pats) = tp _LOC undefined pats + typ _ = Nothing + + in Map.fromList [ (findWithErr1 "Rule.defines" aa @lhs.altAttrs, (field,attr,(tp field attr))) + | (field,attr,isLocalOrInst) <- @pattern.patternAttrs + , let aa = AltAttr field attr isLocalOrInst + ] + loc.gathRules = let childnt field = Map.lookup field @lhs.childNts + in Seq.fromList [ CRule attr False True @lhs.nt @lhs.con field (childnt field) tp @pattern.copy @rhs.textLines @defines @owrt @origin @rhs.allRhsVars @explicit @mbName + | (field,attr,tp) <- Map.elems @defines + ] + +{ +substSelf nt tp + = case tp of + NT n tps defor | n == _SELF -> NT nt tps defor + _ -> tp + +haskellTupel :: [Type] -> Maybe Type +haskellTupel ts = Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" )) +} + + +ATTR Patterns Pattern [ | | patternAttrs USE {++} {[]} : {[(Identifier,Identifier,Bool)]} ] + +SEM Pattern + | Alias lhs.patternAttrs = [(@field,@attr,(@field == _LOC || @field == _INST))] + + + +-- Giving them a number +ATTR Nonterminals Nonterminal Productions Production + [ | vcount : Int + | rules USE {Seq.><} {Seq.empty} : {Seq (Vertex,CRule)}] +SEM Grammar + | Grammar nonts.vcount = 0 +SEM Production + | Production lhs.rules = Seq.fromList (zip [@lhs.vcount..] @gathRules) + lhs.vcount = @lhs.vcount + length @gathRules + +-- Direct dependencies +ATTR Nonterminals Nonterminal + Productions Production + Rules Rule [ | | directDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] +SEM Rule + | Rule lhs.directDep + = let defined = Map.keys @defines + used = [ Map.lookup (AltAttr field attr True) @lhs.altAttrs | (field,attr) <- @rhs.usedAttrs] + ++ [ Map.lookup (AltAttr _LOC attr True) @lhs.altAttrs | attr <- @rhs.usedLocals ++ @rhs.usedFields ] + in Seq.fromList [ (x,y) | Just x <- used, y <- defined ] + +-- Manual depdendencies (provided by the programmer) +-- +-- a dependency f1.a1 < f2.a2 is translated to +-- the edge (vertex(f1.a1), vertex(f2.a2)) +ATTR Nonterminals Nonterminal + Productions Production + [ manualAttrDepMap : {AttrOrderMap} | | additionalDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] + +SEM Grammar + | Grammar + nonts.manualAttrDepMap = @manualAttrOrderMap + +SEM Production + | Production + loc.manualDeps + = Set.toList $ Map.findWithDefault Set.empty @con $ Map.findWithDefault Map.empty @lhs.nt @lhs.manualAttrDepMap + + lhs.additionalDep + = Seq.fromList [ (vertex True occA, vertex False occB) + | Dependency occA occB <- @loc.manualDeps + , let vertex inout (OccAttr child nm) + | child == _LOC = findWithErr2 (AltAttr _LOC nm True) @loc.altAttrs + | otherwise = findWithErr2 (AltAttr child nm inout) @loc.altAttrs + vertex _ (OccRule nm) + = findWithErr2 (AltAttr _LOC (Ident ("_rule_" ++ show nm) (getPos nm)) True) @loc.altAttrs + ] + +-- Inst dependencies +-- +-- For each inst attribute x of nt N, add the dependency +-- (inst.x,x.y) for each synthesized attribute of N +-- + +ATTR Nonterminals Nonterminal + Productions Production + Rules Rule [ | | instDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] +SEM Rule + | Rule + loc.instDep1 + = Seq.fromList $ + [ (instVert, synVert) + | (field,instNm,_) <- Map.elems @defines + , field == _INST + , synNm <- Map.keys (findWithErr2 instNm @lhs.synsOfChildren) + , let instAttr = AltAttr _INST instNm True + synAttr = AltAttr instNm synNm True + instVert = findWithErr2 instAttr @lhs.altAttrs + synVert = findWithErr2 synAttr @lhs.altAttrs + ] + loc.instDep2 + = Seq.fromList $ + [ (instVert, inhVert) + | (field,instNm,_) <- Map.elems @defines + , field == _INST + , inhNm <- Map.keys (findWithErr2 instNm @lhs.inhsOfChildren) + , let instAttr = AltAttr _INST instNm True + inhAttr = AltAttr instNm inhNm False + instVert = findWithErr2 instAttr @lhs.altAttrs + inhVert = findWithErr2 inhAttr @lhs.altAttrs + ] + lhs.instDep = @loc.instDep1 Seq.>< @loc.instDep2 + +ATTR Rules Rule [ synsOfChildren, inhsOfChildren : {Map Identifier Attributes} | | ] +SEM Production + | Production rules.synsOfChildren = @children.collectChildrenSyns + rules.inhsOfChildren = @children.collectChildrenInhs + +ATTR Children Child [ | | collectChildrenSyns, collectChildrenInhs USE {`Map.union`} {Map.empty} : {Map Identifier Attributes } ] +SEM Child + | Child lhs.collectChildrenSyns = Map.singleton @name @loc.syn + lhs.collectChildrenInhs = Map.singleton @name @loc.inh + +-- +-- Merge stuff +-- + +ATTR Nonterminals Nonterminal + [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ] + +ATTR Productions Production + [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))} | | ] + +SEM Nonterminal | Nonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap +SEM Production | Production loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap + +ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ] + +-- for a child c : N, with merged children cs, add dependencies between synthesized attrs of +-- c to synthesized attrs of cs, and to the merge-attribute +ATTR Nonterminals Nonterminal Productions Production + [ | | mergeDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] + +SEM Production + | Production + lhs.mergeDep = @loc.mergeDep1 Seq.>< @loc.mergeDep2 + loc.mergeDep1 + = Seq.fromList $ + [ (childVert, synVert) + | childNm <- Map.keys @loc.mergeMap + , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns) + , let childNm' = Ident (show childNm ++ "_merge") (getPos childNm) + childAttr = AltAttr _LOC childNm' True + synAttr = AltAttr childNm synNm True + childVert = findWithErr2 childAttr @loc.altAttrs + synVert = findWithErr2 synAttr @loc.altAttrs + ] + loc.mergeDep2 + = Seq.fromList $ + [ (mergedVert, sourceVert) + | (childNm, (_,cs)) <- Map.assocs @loc.mergeMap + , c <- cs + , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns) + , let sourceAttr = AltAttr childNm synNm True + mergedAttr = AltAttr c synNm True + sourceVert = findWithErr2 sourceAttr @loc.altAttrs + mergedVert = findWithErr2 mergedAttr @loc.altAttrs + ] + + +-- Around dependencies +-- +-- For each around x_around on x of nt N, add the dependency +-- (x_around, x.y) for each synthesized attribute y of N +-- + +ATTR Nonterminals Nonterminal + Productions Production + [ | | aroundDep USE {Seq.><} {Seq.empty} : {Seq Edge} ] + +ATTR Nonterminals Nonterminal + [ aroundMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))} || ] + +ATTR Productions Production + [ aroundMap : {Map ConstructorIdent (Map Identifier [Expression])} || ] + +SEM Nonterminal | Nonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap +SEM Production | Production loc.aroundMap = Map.findWithDefault Map.empty @con @lhs.aroundMap + +SEM Grammar + | Grammar nonts.aroundMap = @aroundsMap + +SEM Production + | Production + loc.aroundDep1 + = Seq.fromList $ + [ (childVert, synVert) + | childNm <- Map.keys @loc.aroundMap + , synNm <- Map.keys (findWithErr2 childNm @children.collectChildrenSyns) + , let childNm' = Ident (show childNm ++ "_around") (getPos childNm) + childAttr = AltAttr _LOC childNm' True + synAttr = AltAttr childNm synNm True + childVert = findWithErr2 childAttr @loc.altAttrs + synVert = findWithErr2 synAttr @loc.altAttrs + ] + loc.aroundDep2 + = Seq.fromList $ + [ (childVert, inhVert) + | childNm <- Map.keys @loc.aroundMap + , inhNm <- Map.keys (findWithErr2 childNm @children.collectChildrenInhs) + , let childNm' = Ident (show childNm ++ "_around") (getPos childNm) + childAttr = AltAttr _LOC childNm' True + inhAttr = AltAttr childNm inhNm False + childVert = findWithErr2 childAttr @loc.altAttrs + inhVert = findWithErr2 inhAttr @loc.altAttrs + ] + lhs.aroundDep = @loc.aroundDep1 Seq.>< @loc.aroundDep2 + + +-- Wrapping an Expression + +ATTR Expression [ nt,con :{Identifier} + allfields:{[(Identifier,Type,ChildKind)]} + allnts :{[Identifier]} + attrs :{[(Identifier,Identifier)]} + options :{Options} + || + errors :{Seq Error} + usedLocals:{[Identifier]} + usedAttrs :{[(Identifier,Identifier)]} + usedFields:{[Identifier]} + textLines :{[String]} + copy : SELF + allRhsVars : {Set (Identifier,Identifier)} + ] + +-- appendum: filter out the syn attrs of merged children in the input attr list. +-- add the merged children to the used attr list +-- appendum: ignored the error reporting on expressions. These are already +-- reported by the separate 'ResolveLocals' pass. +SEM Expression + | Expression loc.(textLines,usedAttrs,usedLocals,usedFields) + = let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ] + attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs + inherited = Inh_HsTokensRoot + { attrs_Inh_HsTokensRoot = attrsIn + , con_Inh_HsTokensRoot = @lhs.con + , allfields_Inh_HsTokensRoot = @lhs.allfields + , allnts_Inh_HsTokensRoot = @lhs.allnts + , nt_Inh_HsTokensRoot = @lhs.nt + , options_Inh_HsTokensRoot = @lhs.options + } + synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited + in case synthesized of + Syn_HsTokensRoot + { textLines_Syn_HsTokensRoot = textLines + , usedAttrs_Syn_HsTokensRoot = usedAttrs + , usedLocals_Syn_HsTokensRoot = usedLocals + , usedFields_Syn_HsTokensRoot = usedFields + } -> let extraAttrs = [ (src,attr) + | (fld,attr) <- usedAttrs, let mbMerged = Map.lookup fld @lhs.mergeMap, isJust mbMerged + , let (Just (_, srcs)) = mbMerged, src <- srcs ] + usedAttrs' = usedAttrs ++ extraAttrs + in (textLines,usedAttrs',usedLocals,usedFields) + + lhs.errors = Seq.empty + lhs.allRhsVars = Set.fromList @loc.usedAttrs + `Set.union` + Set.fromList [ (_LOC, l) | l <- @loc.usedLocals] + `Set.union` + Set.fromList [ (_FIELD, fld) | fld <- @loc.usedFields] + + +------------------------------------- +-- NT-Attributes +------------------------------------- +ATTR Nonterminals Nonterminal + [ | acount : Int | ntattrs USE {Seq.><} {Seq.empty} : {Seq (Vertex,NTAttr)} + aranges USE {Seq.><} {Seq.empty} : {Seq (Int,Int,Int)}] + +SEM Grammar + | Grammar nonts.acount = 0 + +SEM Nonterminal + | Nonterminal loc.ntattrs = [ NTAInh @nt inh tp | (inh,tp) <- Map.assocs @inh ] + ++ [NTASyn @nt syn tp | (syn,tp) <- Map.assocs @syn ] + lhs.ntattrs = Seq.fromList (zip [@lhs.acount ..] @ntattrs) + lhs.acount = @lhs.acount + Map.size @inh + Map.size @syn + lhs.aranges = Seq.singleton + (@lhs.acount + ,@lhs.acount + Map.size @inh + ,@lhs.acount + Map.size @syn + Map.size @inh - 1) +------------------------------------------------------------------ +-- Pass structure up +------------------------------------------------------------------ +ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ] +SEM Nonterminal + | Nonterminal lhs.nonts = [(@nt,@prods.cons)] +ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ] +SEM Production + | Production lhs.cons = [@con] + +------------------------------------------------------------------ +-- Collect type signatures +------------------------------------------------------------------ +ATTR TypeSigs TypeSig [ | typeSigs : {Map Identifier Type} | ] +SEM Production + | Production typeSigs.typeSigs = Map.empty +SEM TypeSig + | TypeSig lhs.typeSigs = Map.insert @name @tp @lhs.typeSigs + +ATTR Rules Rule Patterns Pattern [ allTypeSigs : {Map Identifier Type} | | ] +SEM Production + | Production rules.allTypeSigs = @typeSigs.typeSigs + +------------------------------------------------------------------ +-- Invoking sequential computation +------------------------------------------------------------------ +SEM Grammar + | Grammar loc.ruleTable = Array.array (0,@nonts.vcount-1) (toList @nonts.rules) + loc.attrTable = Array.array (0,@nonts.acount-1) (toList @nonts.ntattrs) + loc.attrVertex = Map.fromList (map swap (toList @nonts.ntattrs)) + loc.tdpToTds = [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v @attrVertex) (ntattr cr)) + | (s,cr) <- toList @nonts.rules] + loc.tdsToTdp = let eq (_,v) (_,v') = v == v' + conv ((s,v):svs) | v == -1 = Nothing + | otherwise = Just (v,s:map fst svs) + in mapMaybe conv (eqClasses eq @tdpToTds) + loc.directDep = toList (@nonts.directDep Seq.>< @nonts.additionalDep) + loc.instDep = toList @nonts.instDep + loc.aroundDep = toList @nonts.aroundDep + loc.mergeDep = toList @nonts.mergeDep + loc.info = let def [] = -1 + def (v:vs) = v + in Info { tdsToTdp = Array.array (0,@nonts.acount-1) @tdsToTdp + , tdpToTds = Array.array (0,@nonts.vcount-1) @tdpToTds + , attrTable = @attrTable + , ruleTable = @ruleTable + , lmh = toList @nonts.aranges + , nonts = @nonts.nonts + , wraps = @wrappers + } + + loc.(cInterfaceMap,cVisitsMap,cyclesErrors) = + case computeSequential @info @directDep (@instDep ++ @aroundDep ++ @loc.mergeDep) of + CycleFree cim cvm -> ( cim + , cvm + , [] + ) + LocalCycle errs -> ( error "No interfaces for AG with local cycles" + , error "No visit sub-sequences for AG with local cycles" + , map (localCycleErr @ruleTable (visit @lhs.options)) errs + ) + InstCycle errs -> ( error "No interfaces for AG with cycles through insts" + , error "No visit sub-sequences for AG with cycles through insts" + , map (instCycleErr @ruleTable (visit @lhs.options)) errs + ) + DirectCycle errs -> ( error "No interfaces for AG with direct cycles" + , error "No visit sub-sequences for AG with direct cycles" + , directCycleErrs @attrTable @ruleTable (visit @lhs.options) errs + ) + InducedCycle cim errs -> ( cim + , error "No visit sub-sequences for AG with induced cycles" + , inducedCycleErrs @attrTable @ruleTable cim errs + ) + lhs.errors = (if withCycle @lhs.options then Seq.fromList @cyclesErrors else Seq.empty) + Seq.>< @nonts.errors + +------------------------------------------------------------------ +-- Generate CGrammar +------------------------------------------------------------------ +-- Pass InterfaceMap down and select the Interface in the Nonterminal +ATTR Nonterminals Nonterminal [ cInterfaceMap : CInterfaceMap | | ] +SEM Nonterminal + | Nonterminal loc.cInter = if @lhs.o_dovisit + then findWithErr1 "Nonterminal.cInter" @nt @lhs.cInterfaceMap + else CInterface [CSegment @inh @syn] + +-- Pass VisitMap down and select the CVisits in the Production +ATTR Nonterminals Nonterminal Productions Production [ cVisitsMap : CVisitsMap | | ] +SEM Production + | Production loc.cVisits = if @lhs.o_dovisit + then let prodsVisitsMap = findWithErr1 "Production.cVisits.nt" @lhs.nt @lhs.cVisitsMap + visits = findWithErr1 "Production.cVisits.con" @con prodsVisitsMap + in visits + else let vss = nubBy eqCRuleDefines @gathRules ++ @children.singlevisits + in [CVisit @lhs.inh @lhs.syn vss [] False] + +-- Declarations for single visits +ATTR Child Children [ | | singlevisits USE {++} {[]}: {[CRule]}] +SEM Child + | Child lhs.singlevisits = if @maptolocal + then [] + else [CChildVisit @name (getNtName @tp) 0 @loc.inh @loc.syn True] + +-- Now just build the CGrammar +SEM Grammar [ | | output : CGrammar ] + | Grammar lhs.output = CGrammar @typeSyns @derivings @wrappers @nonts.cNonterminals @pragmas @paramMap @contextMap @quantMap @loc.aroundMap @loc.mergeMap @loc.o_dovisit +SEM Nonterminals [ | | cNonterminals : CNonterminals ] + | Cons lhs.cNonterminals = @hd.cNonterminal : @tl.cNonterminals + | Nil lhs.cNonterminals = [] +SEM Nonterminal [ | | cNonterminal : CNonterminal ] + | Nonterminal lhs.cNonterminal = CNonterminal @nt @params @inh @syn @prods.cProductions @cInter +SEM Productions [ | | cProductions : CProductions ] + | Cons lhs.cProductions = @hd.cProduction : @tl.cProductions + | Nil lhs.cProductions = [] +SEM Production [ | | cProduction : CProduction ] + | Production lhs.cProduction = CProduction @con @cVisits @children.fields @children.terminals + +SEM Grammar + | Grammar loc.aroundMap = Map.map (Map.map Map.keysSet) @aroundsMap + loc.mergeMap = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap + +-- Collect terminals +ATTR Children Child [ | | terminals USE {++} {[]} : {[Identifier]} ] +SEM Child + | Child lhs.terminals = if @maptolocal + then [@name] + else [] + + +-- Collecting nts +ATTR Nonterminal Nonterminals + Production Productions + Rule Rules + Child Children [allnts:{[Identifier]} | | ] + +SEM Grammar + | Grammar nonts.allnts = map fst (@nonts.nonts) + +-- Collecting fields +ATTR Rule Rules + Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ] + +SEM Production + | Production loc.allfields = @children.fields + .attrs = map ((,) _LOC) @rules.locVars ++ + map ((,) _INST) @rules.instVars ++ + map ((,) _LHS) @inhnames ++ + concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes] + .inhnames = Map.keys @lhs.inh + .synnames = Map.keys @lhs.syn + +ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ] +SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ] + | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)] + + +SEM Child [ | | field : {(Identifier,Type,ChildKind)} ] + | Child lhs.field = (@name, @tp, @kind) + +SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ] + | Cons lhs.fields = @hd.field : @tl.fields + | Nil lhs.fields = [] + +ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ] + +SEM Pattern + | Alias lhs.locVars = if @field == _LOC + then [@attr] + else [] + lhs.instVars = if @field == _INST + then [@attr] + else [] + +{ +swap (a,b) = (b,a) + +showPath :: Table CRule -> [Vertex] -> [String] +showPath ruleTable path + = let look a | inRange (bounds ruleTable) a = [showOrigin (ruleTable ! a)] + | otherwise = ["Vertex " ++ show a] + showOrigin cr | getHasCode cr && getName (getAttr cr) /= "self" = prettyCRule cr ++ " (" ++ show (getPos (getAttr cr)) ++ ")" + | otherwise = prettyCRule cr + in concatMap look path + + +showPathLocal :: Table CRule -> [Vertex] -> [String] +showPathLocal _ [] = [] +showPathLocal ruleTable xs = showP (xs++[-1]) + where showP [] = [] + showP (v1:v2:vs) = let line = step v1 v2 + lines = showP vs + in line:lines + step v1 v2 = " - " ++ a1 + where r1 = ruleTable ! v1 + a1 = show (getAttr r1) + + +limitTo :: Int -> [String] -> [String] +limitTo _ [] = [] +limitTo 0 _ = ["....etcetera, etcetera...."] +limitTo n (x:xs) = x : limitTo (n-1) xs + +showPathNice :: Table CRule -> [Vertex] -> [String] +showPathNice _ [] = [] +showPathNice ruleTable xs = limitTo 100 (showP ((-1):xs++[-1])) + where [maxf, maxa, maxn, maxc] = maxWidths ruleTable (take 100 xs) + showP [] = [] + showP (v1:v2:vs) = let line = step v1 v2 + lines = showP vs + in if null line then lines else line:lines + step v1 v2 | last && first = induced + | last && isSyn r1 = "pass up " ++ alignR maxf "" ++ " " ++ alignL maxa a1 ++ " in " ++ alignR maxn n1 ++ "|" ++ c1 ++ induced + | first&& not(isSyn r2) = "get from above " ++ alignR maxf "" ++ " " ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 + | last = "pass down " ++ alignR maxf f1 ++ "." ++ a1 ++ induced + | isSyn r2 = "get from below " ++ alignR maxf f2 ++ "." ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 + | isLocal r1 = if head a1 == '_' + then "" + else "calculate " ++ alignR maxf "loc" ++ "." ++ a1 + | otherwise = "pass down " ++ alignR maxf f1 ++ "." ++ alignL maxa a1 ++ " to " ++ alignR maxn n2 ++ "|" ++ c2 + where + first = v1<0 + last = v2<0 + r1 = ruleTable ! v1 + r2 = ruleTable ! v2 + a1 = show (getAttr r1) + a2 = show (getAttr r2) + f1 = show (getField r1) + f2 = show (getField r2) + n1 = show (getLhsNt r1) + n2 = show (getLhsNt r2) + c1 = show (getCon r1) + c2 = show (getCon r2) + induced | v2== -2 = " INDUCED dependency to " + | otherwise = "" + + +maxWidths ruleTable vs + = map maximum (transpose (map getWidth vs)) + where getWidth v | v<0 = [0,0,0,0] + | otherwise = map (length . show . ($ (ruleTable!v))) [getField, getAttr, getLhsNt, getCon] + +alignL n xs | k Bool -> Route -> Error +localCycleErr ruleTable o_visit (s:path) + = let cr = ruleTable ! s + attr = getAttr cr + nt = getLhsNt cr + con = getCon cr + in LocalCirc nt con attr o_visit (showPathLocal ruleTable path) + +instCycleErr :: Table CRule -> Bool -> Route -> Error +instCycleErr ruleTable o_visit (s:path) + = let cr = ruleTable ! s + attr = getAttr cr + nt = getLhsNt cr + con = getCon cr + in InstCirc nt con attr o_visit (showPathLocal ruleTable path) + +directCycleErrs :: Table NTAttr -> Table CRule -> Bool -> [EdgeRoutes] -> [Error] +directCycleErrs attrTable ruleTable o_visit xs + = let getNont v = case attrTable ! v of + NTASyn nt _ _ -> nt + NTAInh nt _ _ -> nt + getAttr v = case attrTable ! v of + NTASyn _ a _ -> a + NTAInh _ a _ -> a + sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 + procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) + wrapGroup gr@(((v1,_),_,_):_) = DirectCirc (getNont v1) o_visit (map procCycle gr) + in map wrapGroup (groupBy sameNont xs) + +inducedCycleErrs :: Table NTAttr -> Table CRule -> CInterfaceMap -> [EdgeRoutes] -> [Error] +inducedCycleErrs attrTable ruleTable cim xs + = let getNont v = case attrTable ! v of + NTASyn nt _ _ -> nt + NTAInh nt _ _ -> nt + getAttr v = case attrTable ! v of + NTASyn _ a _ -> a + NTAInh _ a _ -> a + sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 + procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) + wrapGroup gr@(((v1,_),_,_):_) = InducedCirc (getNont v1) (findWithErr1 "inducedCycleErr.cinter" (getNont v1) cim) (map procCycle gr) + in map wrapGroup (groupBy sameNont xs) +} diff --git a/src-ag/Patterns.ag b/src-ag/Patterns.ag --- a/src-ag/Patterns.ag +++ b/src-ag/Patterns.ag @@ -1,25 +1,25 @@ -imports -{ --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) -} - -TYPE Patterns = [Pattern] - -DATA Pattern | Constr name : {ConstructorIdent} - pats : Patterns - | Product pos : {Pos} - pats : Patterns - | Alias field : {Identifier} - attr : {Identifier} - pat : Pattern - | Irrefutable pat : Pattern - | Underscore pos : {Pos} - -DERIVING Pattern:Show - -ATTR AllPattern [ | | copy : SELF ] - -SET AllPattern - = Pattern Patterns +imports +{ +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) +} + +TYPE Patterns = [Pattern] + +DATA Pattern | Constr name : {ConstructorIdent} + pats : Patterns + | Product pos : {Pos} + pats : Patterns + | Alias field : {Identifier} + attr : {Identifier} + pat : Pattern + | Irrefutable pat : Pattern + | Underscore pos : {Pos} + +DERIVING Pattern:Show + +ATTR AllPattern [ | | copy : SELF ] + +SET AllPattern + = Pattern Patterns diff --git a/src-ag/PrintCleanCode.ag b/src-ag/PrintCleanCode.ag --- a/src-ag/PrintCleanCode.ag +++ b/src-ag/PrintCleanCode.ag @@ -1,563 +1,563 @@ -PRAGMA strictdata -PRAGMA optimize -PRAGMA bangpats -PRAGMA strictwrap - -INCLUDE "Code.ag" -INCLUDE "Patterns.ag" - -imports -{ -import Data.Char (isAlphaNum) -import Pretty -import Code -import Options -import CommonTypes (attrname, _LOC, nullIdent) -import Data.List(intersperse) -import System.IO -import System.Directory -import System.FilePath -import CommonTypes(BlockInfo, BlockKind(..)) -} - -{ -type PP_Docs = [PP_Doc] -} - -{ -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs -} - -ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ] - -SEM Chunk - | Chunk - loc.outputfile = if sepSemMods @lhs.options - then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name) - else @lhs.mainFile - -ATTR Program [ options:{Options} | | output:{PP_Docs} ] - -ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ] - -ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ] -ATTR Decl DataAlt NamedType [ | | ppa USE {>-<} {empty} : {PP_Doc}] - -ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ] -ATTR DataAlts NamedTypes [ | | ppas : {PP_Docs} ] - -ATTR CaseAlt CaseAlts [ nested:{Bool} | | pps: {PP_Docs} ] - -ATTR Type Types [ | | copy : SELF] - -SEM Program | Program - loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered } - -SEM Program - | Program chunks.nested = nest @lhs.options - -SEM Exprs - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM CaseAlts - | Cons lhs.pps = @hd.pps ++ @tl.pps - | Nil lhs.pps = [] - -SEM DataAlts - | Cons lhs.pps = @hd.pp : @tl.pps - lhs.ppas = @hd.ppa : @tl.ppas - | Nil lhs.pps = [] - lhs.ppas = [] - -SEM Types - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM NamedTypes - | Cons lhs.pps = @hd.pp : @tl.pps - lhs.ppas = @hd.ppa : @tl.ppas - | Nil lhs.pps = [] - lhs.ppas = [] - -SEM Decls - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Chunks - | Cons lhs.pps = @hd.pps ++ @tl.pps - | Nil lhs.pps = [] - - -SEM Program - | Program lhs.output = @chunks.pps - -SEM Chunk - | Chunk lhs.pps = @comment.pp - : @info.pps - ++ @dataDef.pps - ++ @cataFun.pps - ++ @semDom.pps - ++ @semWrapper.pps - ++ @semFunctions.pps - ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap] - -SEM Decl - | Decl lhs.pp = @left.pp >#< "=" - >-< indent 4 @rhs.pp - | Bind lhs.pp = @left.pp >#< "<-" >#< @rhs.pp - | BindLet lhs.pp = "let" >#< @left.pp >#< "=" >#< @rhs.pp - | Data lhs.pp = "::" >#< hv_sp (@name : @params) - >#< ( case @alts.pps of - [] -> empty - (x:xs) -> "=" >#< x - >-< vlist (map ("|" >#<) xs) - >-< if null @derivings - then empty - else "deriving" >#< ppTuple False (map text @derivings) - ) - >-< foldr (>-<) empty @alts.ppas - - | NewType lhs.pp = "::" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp - | Type lhs.pp = "::" >#< hv_sp (@name : @params) >#< ":==" >#< @tp.pp - | TSig lhs.pp = @name >#< "::" >#< @tp.pp - | Comment lhs.pp = if '\n' `elem` @txt - then "/*" >-< vlist (lines @txt) >-< "*/" - else "//" >#< @txt - | PragmaDecl lhs.pp = "/*#" >#< text @txt >#< "#*/" -- Not used in Clean - | Resume lhs.pp = if @monadic - then @left.pp >#< "<-" >#< @rhs.pp - else @left.pp >#< "=" >-< indent 4 @rhs.pp - | EvalDecl loc.strat = if breadthFirstStrict @lhs.options - then "stepwiseEval" - else "lazyEval" - lhs.pp = if breadthFirst @lhs.options - then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of" - >-< indent 4 ( - pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val" - ) - else @left.pp >#< "=" >#< @rhs.pp - -SEM Expr - | Let lhs.pp = pp_parens ( "let" >#< (vlist @decls.pps) - >-< "in " >#< @body.pp - ) - | Case lhs.pp = pp_parens ( "case" >#< pp_parens @expr.pp >#< "of" - >-< (vlist @alts.pps) - ) - | Do lhs.pp = pp_parens ( "do" >#< ( vlist @stmts.pps - >-< ("return" >#< @body.pp)) - ) - | Lambda loc.strictParams = if strictSems @lhs.options - then @args.pps - else [] - loc.addBang = if bangpats @lhs.options - then \p -> pp_parens ("!" >|< p) - else id - lhs.pp = pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->" - >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp) - ) - | TupleExpr lhs.pp = ppTuple @lhs.nested @exprs.pps - | UnboxedTupleExpr lhs.pp = ppUnboxedTuple @lhs.nested @exprs.pps - | App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps - | SimpleExpr lhs.pp = text @txt - | TextExpr lhs.pp = vlist (map text @lns) - | Trace lhs.pp = "trace" >#< ( pp_parens ("\"" >|< text @txt >|< "\"") - >-< pp_parens @expr.pp - ) - | PragmaExpr lhs.pp = let pragmaDoc = "/*#" >#< @txt >#< "#*/" -- Not used in Clean - op = if @onNewLine - then (>-<) - else (>#<) - leftOp x y = if @onLeftSide - then x `op` y - else y - rightOp x y = if @onLeftSide - then x - else x `op` y - in pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc) - | LineExpr lhs.pp = @expr.pp >-< "/*# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#*/" - >-< "" - | TypedExpr lhs.pp = pp_parens (@expr.pp >#< "::" >#< @tp.pp) - | ResultExpr lhs.pp = if breadthFirst @lhs.options - then "final" >#< - pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp) - else @expr.pp - | InvokeExpr lhs.pp = if breadthFirst @lhs.options - then "invoke" >#< pp_parens @expr.pp >#< pp_parens ( - @nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps)) - else @expr.pp >#< hv_sp @args.pps - | ResumeExpr lhs.pp = if breadthFirst @lhs.options - then pp_parens ("resume" >#< pp_parens @expr.pp - >-< indent 2 (pp_parens ( "\\" >|< - pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg")) - >#< "->" - >-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg" - >-< indent 2 ("in" >#< @rhs.pp) - )))) - else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of" - >-< ("{" >#< @left.pp >#< "->") - >-< indent 4 (@rhs.pp >#< "}") - ) - | SemFun loc.strictParams = if strictSems @lhs.options - then @args.pps - else [] - loc.addBang = if bangpats @lhs.options - then \p -> pp_parens ("!" >|< p) - else id - lhs.pp = if breadthFirst @lhs.options - then "Child" >#< pp_parens ( "\\" >|< - pp_parens (@nt >|< "_Inh" >#< - ppTuple False (map @loc.addBang @args.pps)) >#< "->" - >-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp)) - else if null @args.pps - then @body.pp - else pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->" - >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp) - ) - -SEM CaseAlt - | CaseAlt lhs.pps = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"] - -SEM DataAlt - | DataAlt lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) - lhs.ppa = empty - | Record lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) -- @name >#< pp_block "{" "}" "," @args.pps - lhs.ppa = let f n d = d >#< (pp_block ("(" ++ @name) ")" "" $ map pp (ppat n)) - >#< pp "=" >#< pp "x" - ppat n = replicate (length @args.ppas - n - 1) (pp " _") ++ [pp " x"] ++ replicate n (pp " _") - in snd $ foldr (\x (n, xs) -> (n + 1, f n x >-< xs)) (0, empty) @args.ppas - -SEM NamedType - | Named lhs.pp = -- @name >#< "::" >#< - if @strict - then "!" >|< pp_parens @tp.pp - else @tp.pp - lhs.ppa = pp @name - -SEM Lhs - | Pattern3 TupleLhs UnboxedTupleLhs - loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id - | Pattern3 - loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True") - loc.hasStrictVars = not (null @pat3.strictVars) - | TupleLhs UnboxedTupleLhs - loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet - then map text @comps `ppMultiSeqH` (pp "True") - else pp "True" - loc.hasStrictVars = not (null @comps) - - | Fun - loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id - loc.hasStrictVars = not (null @args.pps) - loc.strictGuard = @args.pps `ppMultiSeqH` (pp "True") - - | TupleLhs UnboxedTupleLhs Fun - loc.addBang = if bangpats @lhs.options - then \p -> "!" >|< p - else id - - | Pattern3 lhs.pp = @loc.addStrictGuard @pat3.pp - | Pattern3SM lhs.pp = @pat3.pp' - | TupleLhs lhs.pp = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps) - | UnboxedTupleLhs lhs.pp = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps) - | Fun lhs.pp = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps)) - | Unwrap lhs.pp = pp_parens (@name >#< @sub.pp) - -SEM Type [ | | prec:Int ] - | Arr lhs.prec = 2 - .pp = case @right.copy of - Arr{} -> @loc.l >-< @loc.r - _ -> @loc.l >#< "->" >-< @loc.r - loc.l = if @left.prec <= 2 then pp_parens @left.pp else @left.pp - .r = if @right.prec < 2 then pp_parens @right.pp else @right.pp - - | TypeApp - lhs.pp = pp "(" >#< hv_sp (@func.pp : @args.pps) >#< pp ")"-- TODO: Check - - | CtxApp - lhs.pp = @right.pp >#< " | " >#< (pp_block "" "" "&" $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left) - | QuantApp - lhs.pp = @left >#< @right.pp - - | TupleType lhs.prec = 5 - .pp = ppTuple @lhs.nested @tps.pps - - | UnboxedTupleType lhs.prec = 5 - .pp = ppUnboxedTuple @lhs.nested @tps.pps - - | List lhs.prec = 5 - .pp = "[" >|< @tp.pp >|< "]" - - | SimpleType lhs.prec = 5 - .pp = if reallySimple @txt then text @txt else pp_parens (text @txt) - - | NontermType lhs.prec = 5 - lhs.pp = @loc.prefix >|< text @name >#< hv_sp @params - loc.prefix = if @deforested - then text "T_" - else empty - | TMaybe lhs.prec = 5 - lhs.pp = text "Maybe" >#< pp_parens @tp.pp - | TEither lhs.prec = 5 - lhs.pp = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp - | TMap lhs.prec = 5 - lhs.pp = text "'Data.Map'.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp - | TIntMap lhs.prec = 5 - lhs.pp = text "'Data.IntMap'.IntMap" >#< pp_parens @value.pp - | TSet lhs.prec = 5 - lhs.pp = text "'Data.Set'.Set" >#< pp_parens @tp.pp - | TIntSet lhs.prec = 5 - lhs.pp = text "'Data.IntSet'.IntSet" - - -{ - -reallySimple :: String -> Bool -reallySimple = and . map (\x -> isAlphaNum x || x=='_') - -ppTuple :: Bool -> [PP_Doc] -> PP_Doc -ppTuple _ [x] = pp x -ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps -ppTuple False pps = "(" >|< pp_block " " ")" "," pps -ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc -ppUnboxedTuple = ppTuple ---ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps ---ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps - -} - - -------------------------------------------------------------------------------- --- Strict data fields -------------------------------------------------------------------------------- - -ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ] - -SEM Decl - | Data alts.strictPre = if @strict then pp "!" else empty - -------------------------------------------------------------------------------- --- Strict variables -------------------------------------------------------------------------------- - -ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ] -SEM Pattern - | Alias - loc.strictVar - = if strictCases @lhs.options && not @lhs.isDeclOfLet - then [@loc.ppVar] - else [] - loc.strictPatVars - = if stricterCases @lhs.options && not @lhs.isDeclOfLet - then @pat.strictVars - else [] - lhs.strictVars - = @loc.strictVar ++ @loc.strictPatVars - | Irrefutable - lhs.strictVars = [] - -------------------------------------------------------------------------------- --- Pretty printing patterns -------------------------------------------------------------------------------- - -SEM Patterns [ | | pps : {[PP_Doc]} ] - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Pattern - | Constr Product Alias - loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable - then \p -> "!" >|< p - else id - -SEM Pattern [ | | pp:PP_Doc ] - | Constr lhs.pp = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps - | Product lhs.pp = @loc.addBang $ pp_block "(" ")" "," @pats.pps - | Alias loc.ppVar = pp (attrname @lhs.options False @field @attr) - loc.ppVarBang = @loc.addBang $ @loc.ppVar - lhs.pp = if @pat.isUnderscore - then @loc.ppVarBang - else @loc.ppVarBang >|< "@" >|< @pat.pp - | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp - | Underscore lhs.pp = text "_" - -SEM Pattern [ | | isUnderscore:{Bool}] - | Constr lhs.isUnderscore = False - | Product lhs.isUnderscore = False - | Alias lhs.isUnderscore = False - | Underscore lhs.isUnderscore = True - -ATTR Pattern Patterns [ belowIrrefutable : Bool | | ] -SEM Pattern - | Irrefutable - pat.belowIrrefutable = True - -SEM Lhs - | Pattern3 Pattern3SM - pat3.belowIrrefutable = False - -------------------------------------------------------------------------------- --- Pretty printing patterns for SM -------------------------------------------------------------------------------- - -SEM Patterns [ | | pps' : {[PP_Doc]} ] - | Cons lhs.pps' = @hd.pp' : @tl.pps' - | Nil lhs.pps' = [] - -SEM Pattern [ | | pp':PP_Doc ] - | Constr lhs.pp' = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps') - | Product lhs.pp' = pp_block "(" ")" "," @pats.pps' - | Alias lhs.pp' = let attribute | @field == _LOC || @field == nullIdent = locname' @attr - | otherwise = attrname @lhs.options False @field @attr - in attribute >|< "@" >|< @pat.pp' - | Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp - | Underscore lhs.pp' = text "_" - -{ -locname' :: Identifier -> [Char] -locname' n = "_loc_" ++ getName n -} - -------------------------------------------------------------------------------- --- Determine if inside a Let -------------------------------------------------------------------------------- - -ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ] -SEM Program - | Program - chunks.isDeclOfLet = False - -SEM Expr - | Let - decls.isDeclOfLet = True - | Do - stmts.isDeclOfLet = False - | ResumeExpr - left.isDeclOfLet = False - -SEM CaseAlt - | CaseAlt - left.isDeclOfLet = False - - - -------------------------------------------------------------------------------- --- Alternative code printing to separate modules -------------------------------------------------------------------------------- - -ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ] -ATTR Program Chunks Chunk - [ importBlocks : PP_Doc - pragmaBlocks : String - textBlocks : PP_Doc - textBlockMap : {Map BlockInfo PP_Doc} - optionsLine : String - mainFile : String - mainName : String - moduleHeader : {String -> String -> String -> Bool -> String} - | | ] - -SEM Program - | Program - loc.mainModuleFile = @lhs.mainFile - loc.genMainModule - = writeModule @loc.mainModuleFile - ( [ pp $ @lhs.pragmaBlocks - , pp $ @lhs.optionsLine - , pp $ @lhs.moduleHeader @lhs.mainName "" "" False - , pp $ ("import " ++ @lhs.mainName ++ "_common\n") - ] - ++ map pp @chunks.imports - ++ map vlist @chunks.appendMain - ++ [@lhs.mainBlocksDoc] - ) - - loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") - loc.genCommonModule - = writeModule @loc.commonFile - ( [ pp $ @lhs.pragmaBlocks - , pp $ @lhs.optionsLine - , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True - , @lhs.importBlocks - , @lhs.textBlocks - ] - ++ map vlist @chunks.appendCommon - ) - - lhs.genIO = do @loc.genMainModule - @loc.genCommonModule - @chunks.genSems - -{ -renderDocs :: [PP_Doc] -> String -renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" -} - -ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ] -SEM Chunk - | Chunk - lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"] - -ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ] - -SEM Chunk - | Chunk - lhs.appendCommon - = [ [@comment.pp] - , @dataDef.pps - , @semDom.pps - , if reference @lhs.options then @semWrapper.pps else [] - ] - lhs.appendMain - = [ [@comment.pp] - , @cataFun.pps - , if reference @lhs.options then [] else @semWrapper.pps - ] - -ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ] - -SEM Chunk - | Chunk - lhs.genSems - = writeModule @loc.outputfile - [ pp $ @lhs.pragmaBlocks - , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap - , pp $ @lhs.optionsLine - , pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True - , pp $ ("import " ++ @lhs.mainName ++ "_common\n") - , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap - , @comment.pp - , vlist_sep "" @info.pps - , vlist_sep "" @semFunctions.pps - , Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap - ] - -SEM Chunk - | Chunk - loc.exports = concat $ intersperse "," @semNames - -{ -writeModule :: FilePath -> [PP_Doc] -> IO () -writeModule path docs - = do bExists <- doesFileExist path - if bExists - then do input <- readFile path - seq (length input) (return ()) - if input /= output - then dumpIt - else return () - else dumpIt - where - output = renderDocs docs - dumpIt = writeFile path output -} - +PRAGMA strictdata +PRAGMA optimize +PRAGMA bangpats +PRAGMA strictwrap + +INCLUDE "Code.ag" +INCLUDE "Patterns.ag" + +imports +{ +import Data.Char (isAlphaNum) +import Pretty +import Code +import Options +import CommonTypes (attrname, _LOC, nullIdent) +import Data.List(intersperse) +import System.IO +import System.Directory +import System.FilePath +import CommonTypes(BlockInfo, BlockKind(..)) +} + +{ +type PP_Docs = [PP_Doc] +} + +{ +ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqH = ppMultiSeq' (>#<) + +ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqV = ppMultiSeq' (>-<) + +ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeq' next strictArgs expr + = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs +} + +ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ] + +SEM Chunk + | Chunk + loc.outputfile = if sepSemMods @lhs.options + then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name) + else @lhs.mainFile + +ATTR Program [ options:{Options} | | output:{PP_Docs} ] + +ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ] + +ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ] +ATTR Decl DataAlt NamedType [ | | ppa USE {>-<} {empty} : {PP_Doc}] + +ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ] +ATTR DataAlts NamedTypes [ | | ppas : {PP_Docs} ] + +ATTR CaseAlt CaseAlts [ nested:{Bool} | | pps: {PP_Docs} ] + +ATTR Type Types [ | | copy : SELF] + +SEM Program | Program + loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered } + +SEM Program + | Program chunks.nested = nest @lhs.options + +SEM Exprs + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM CaseAlts + | Cons lhs.pps = @hd.pps ++ @tl.pps + | Nil lhs.pps = [] + +SEM DataAlts + | Cons lhs.pps = @hd.pp : @tl.pps + lhs.ppas = @hd.ppa : @tl.ppas + | Nil lhs.pps = [] + lhs.ppas = [] + +SEM Types + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM NamedTypes + | Cons lhs.pps = @hd.pp : @tl.pps + lhs.ppas = @hd.ppa : @tl.ppas + | Nil lhs.pps = [] + lhs.ppas = [] + +SEM Decls + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM Chunks + | Cons lhs.pps = @hd.pps ++ @tl.pps + | Nil lhs.pps = [] + + +SEM Program + | Program lhs.output = @chunks.pps + +SEM Chunk + | Chunk lhs.pps = @comment.pp + : @info.pps + ++ @dataDef.pps + ++ @cataFun.pps + ++ @semDom.pps + ++ @semWrapper.pps + ++ @semFunctions.pps + ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap] + +SEM Decl + | Decl lhs.pp = @left.pp >#< "=" + >-< indent 4 @rhs.pp + | Bind lhs.pp = @left.pp >#< "<-" >#< @rhs.pp + | BindLet lhs.pp = "let" >#< @left.pp >#< "=" >#< @rhs.pp + | Data lhs.pp = "::" >#< hv_sp (@name : @params) + >#< ( case @alts.pps of + [] -> empty + (x:xs) -> "=" >#< x + >-< vlist (map ("|" >#<) xs) + >-< if null @derivings + then empty + else "deriving" >#< ppTuple False (map text @derivings) + ) + >-< foldr (>-<) empty @alts.ppas + + | NewType lhs.pp = "::" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp + | Type lhs.pp = "::" >#< hv_sp (@name : @params) >#< ":==" >#< @tp.pp + | TSig lhs.pp = @name >#< "::" >#< @tp.pp + | Comment lhs.pp = if '\n' `elem` @txt + then "/*" >-< vlist (lines @txt) >-< "*/" + else "//" >#< @txt + | PragmaDecl lhs.pp = "/*#" >#< text @txt >#< "#*/" -- Not used in Clean + | Resume lhs.pp = if @monadic + then @left.pp >#< "<-" >#< @rhs.pp + else @left.pp >#< "=" >-< indent 4 @rhs.pp + | EvalDecl loc.strat = if breadthFirstStrict @lhs.options + then "stepwiseEval" + else "lazyEval" + lhs.pp = if breadthFirst @lhs.options + then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of" + >-< indent 4 ( + pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val" + ) + else @left.pp >#< "=" >#< @rhs.pp + +SEM Expr + | Let lhs.pp = pp_parens ( "let" >#< (vlist @decls.pps) + >-< "in " >#< @body.pp + ) + | Case lhs.pp = pp_parens ( "case" >#< pp_parens @expr.pp >#< "of" + >-< (vlist @alts.pps) + ) + | Do lhs.pp = pp_parens ( "do" >#< ( vlist @stmts.pps + >-< ("return" >#< @body.pp)) + ) + | Lambda loc.strictParams = if strictSems @lhs.options + then @args.pps + else [] + loc.addBang = if bangpats @lhs.options + then \p -> pp_parens ("!" >|< p) + else id + lhs.pp = pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->" + >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp) + ) + | TupleExpr lhs.pp = ppTuple @lhs.nested @exprs.pps + | UnboxedTupleExpr lhs.pp = ppUnboxedTuple @lhs.nested @exprs.pps + | App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps + | SimpleExpr lhs.pp = text @txt + | TextExpr lhs.pp = vlist (map text @lns) + | Trace lhs.pp = "trace" >#< ( pp_parens ("\"" >|< text @txt >|< "\"") + >-< pp_parens @expr.pp + ) + | PragmaExpr lhs.pp = let pragmaDoc = "/*#" >#< @txt >#< "#*/" -- Not used in Clean + op = if @onNewLine + then (>-<) + else (>#<) + leftOp x y = if @onLeftSide + then x `op` y + else y + rightOp x y = if @onLeftSide + then x + else x `op` y + in pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc) + | LineExpr lhs.pp = @expr.pp >-< "/*# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#*/" + >-< "" + | TypedExpr lhs.pp = pp_parens (@expr.pp >#< "::" >#< @tp.pp) + | ResultExpr lhs.pp = if breadthFirst @lhs.options + then "final" >#< + pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp) + else @expr.pp + | InvokeExpr lhs.pp = if breadthFirst @lhs.options + then "invoke" >#< pp_parens @expr.pp >#< pp_parens ( + @nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps)) + else @expr.pp >#< hv_sp @args.pps + | ResumeExpr lhs.pp = if breadthFirst @lhs.options + then pp_parens ("resume" >#< pp_parens @expr.pp + >-< indent 2 (pp_parens ( "\\" >|< + pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg")) + >#< "->" + >-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg" + >-< indent 2 ("in" >#< @rhs.pp) + )))) + else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of" + >-< ("{" >#< @left.pp >#< "->") + >-< indent 4 (@rhs.pp >#< "}") + ) + | SemFun loc.strictParams = if strictSems @lhs.options + then @args.pps + else [] + loc.addBang = if bangpats @lhs.options + then \p -> pp_parens ("!" >|< p) + else id + lhs.pp = if breadthFirst @lhs.options + then "Child" >#< pp_parens ( "\\" >|< + pp_parens (@nt >|< "_Inh" >#< + ppTuple False (map @loc.addBang @args.pps)) >#< "->" + >-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp)) + else if null @args.pps + then @body.pp + else pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->" + >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp) + ) + +SEM CaseAlt + | CaseAlt lhs.pps = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"] + +SEM DataAlt + | DataAlt lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) + lhs.ppa = empty + | Record lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) -- @name >#< pp_block "{" "}" "," @args.pps + lhs.ppa = let f n d = d >#< (pp_block ("(" ++ @name) ")" "" $ map pp (ppat n)) + >#< pp "=" >#< pp "x" + ppat n = replicate (length @args.ppas - n - 1) (pp " _") ++ [pp " x"] ++ replicate n (pp " _") + in snd $ foldr (\x (n, xs) -> (n + 1, f n x >-< xs)) (0, empty) @args.ppas + +SEM NamedType + | Named lhs.pp = -- @name >#< "::" >#< + if @strict + then "!" >|< pp_parens @tp.pp + else @tp.pp + lhs.ppa = pp @name + +SEM Lhs + | Pattern3 TupleLhs UnboxedTupleLhs + loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id + | Pattern3 + loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True") + loc.hasStrictVars = not (null @pat3.strictVars) + | TupleLhs UnboxedTupleLhs + loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet + then map text @comps `ppMultiSeqH` (pp "True") + else pp "True" + loc.hasStrictVars = not (null @comps) + + | Fun + loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id + loc.hasStrictVars = not (null @args.pps) + loc.strictGuard = @args.pps `ppMultiSeqH` (pp "True") + + | TupleLhs UnboxedTupleLhs Fun + loc.addBang = if bangpats @lhs.options + then \p -> "!" >|< p + else id + + | Pattern3 lhs.pp = @loc.addStrictGuard @pat3.pp + | Pattern3SM lhs.pp = @pat3.pp' + | TupleLhs lhs.pp = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps) + | UnboxedTupleLhs lhs.pp = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps) + | Fun lhs.pp = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps)) + | Unwrap lhs.pp = pp_parens (@name >#< @sub.pp) + +SEM Type [ | | prec:Int ] + | Arr lhs.prec = 2 + .pp = case @right.copy of + Arr{} -> @loc.l >-< @loc.r + _ -> @loc.l >#< "->" >-< @loc.r + loc.l = if @left.prec <= 2 then pp_parens @left.pp else @left.pp + .r = if @right.prec < 2 then pp_parens @right.pp else @right.pp + + | TypeApp + lhs.pp = pp "(" >#< hv_sp (@func.pp : @args.pps) >#< pp ")"-- TODO: Check + + | CtxApp + lhs.pp = @right.pp >#< " | " >#< (pp_block "" "" "&" $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left) + | QuantApp + lhs.pp = @left >#< @right.pp + + | TupleType lhs.prec = 5 + .pp = ppTuple @lhs.nested @tps.pps + + | UnboxedTupleType lhs.prec = 5 + .pp = ppUnboxedTuple @lhs.nested @tps.pps + + | List lhs.prec = 5 + .pp = "[" >|< @tp.pp >|< "]" + + | SimpleType lhs.prec = 5 + .pp = if reallySimple @txt then text @txt else pp_parens (text @txt) + + | NontermType lhs.prec = 5 + lhs.pp = @loc.prefix >|< text @name >#< hv_sp @params + loc.prefix = if @deforested + then text "T_" + else empty + | TMaybe lhs.prec = 5 + lhs.pp = text "Maybe" >#< pp_parens @tp.pp + | TEither lhs.prec = 5 + lhs.pp = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp + | TMap lhs.prec = 5 + lhs.pp = text "'Data.Map'.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp + | TIntMap lhs.prec = 5 + lhs.pp = text "'Data.IntMap'.IntMap" >#< pp_parens @value.pp + | TSet lhs.prec = 5 + lhs.pp = text "'Data.Set'.Set" >#< pp_parens @tp.pp + | TIntSet lhs.prec = 5 + lhs.pp = text "'Data.IntSet'.IntSet" + + +{ + +reallySimple :: String -> Bool +reallySimple = and . map (\x -> isAlphaNum x || x=='_') + +ppTuple :: Bool -> [PP_Doc] -> PP_Doc +ppTuple _ [x] = pp x +ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps +ppTuple False pps = "(" >|< pp_block " " ")" "," pps +ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc +ppUnboxedTuple = ppTuple +--ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps +--ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps + +} + + +------------------------------------------------------------------------------- +-- Strict data fields +------------------------------------------------------------------------------- + +ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ] + +SEM Decl + | Data alts.strictPre = if @strict then pp "!" else empty + +------------------------------------------------------------------------------- +-- Strict variables +------------------------------------------------------------------------------- + +ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ] +SEM Pattern + | Alias + loc.strictVar + = if strictCases @lhs.options && not @lhs.isDeclOfLet + then [@loc.ppVar] + else [] + loc.strictPatVars + = if stricterCases @lhs.options && not @lhs.isDeclOfLet + then @pat.strictVars + else [] + lhs.strictVars + = @loc.strictVar ++ @loc.strictPatVars + | Irrefutable + lhs.strictVars = [] + +------------------------------------------------------------------------------- +-- Pretty printing patterns +------------------------------------------------------------------------------- + +SEM Patterns [ | | pps : {[PP_Doc]} ] + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM Pattern + | Constr Product Alias + loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable + then \p -> "!" >|< p + else id + +SEM Pattern [ | | pp:PP_Doc ] + | Constr lhs.pp = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps + | Product lhs.pp = @loc.addBang $ pp_block "(" ")" "," @pats.pps + | Alias loc.ppVar = pp (attrname @lhs.options False @field @attr) + loc.ppVarBang = @loc.addBang $ @loc.ppVar + lhs.pp = if @pat.isUnderscore + then @loc.ppVarBang + else @loc.ppVarBang >|< "@" >|< @pat.pp + | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp + | Underscore lhs.pp = text "_" + +SEM Pattern [ | | isUnderscore:{Bool}] + | Constr lhs.isUnderscore = False + | Product lhs.isUnderscore = False + | Alias lhs.isUnderscore = False + | Underscore lhs.isUnderscore = True + +ATTR Pattern Patterns [ belowIrrefutable : Bool | | ] +SEM Pattern + | Irrefutable + pat.belowIrrefutable = True + +SEM Lhs + | Pattern3 Pattern3SM + pat3.belowIrrefutable = False + +------------------------------------------------------------------------------- +-- Pretty printing patterns for SM +------------------------------------------------------------------------------- + +SEM Patterns [ | | pps' : {[PP_Doc]} ] + | Cons lhs.pps' = @hd.pp' : @tl.pps' + | Nil lhs.pps' = [] + +SEM Pattern [ | | pp':PP_Doc ] + | Constr lhs.pp' = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps') + | Product lhs.pp' = pp_block "(" ")" "," @pats.pps' + | Alias lhs.pp' = let attribute | @field == _LOC || @field == nullIdent = locname' @attr + | otherwise = attrname @lhs.options False @field @attr + in attribute >|< "@" >|< @pat.pp' + | Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp + | Underscore lhs.pp' = text "_" + +{ +locname' :: Identifier -> [Char] +locname' n = "_loc_" ++ getName n +} + +------------------------------------------------------------------------------- +-- Determine if inside a Let +------------------------------------------------------------------------------- + +ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ] +SEM Program + | Program + chunks.isDeclOfLet = False + +SEM Expr + | Let + decls.isDeclOfLet = True + | Do + stmts.isDeclOfLet = False + | ResumeExpr + left.isDeclOfLet = False + +SEM CaseAlt + | CaseAlt + left.isDeclOfLet = False + + + +------------------------------------------------------------------------------- +-- Alternative code printing to separate modules +------------------------------------------------------------------------------- + +ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ] +ATTR Program Chunks Chunk + [ importBlocks : PP_Doc + pragmaBlocks : String + textBlocks : PP_Doc + textBlockMap : {Map BlockInfo PP_Doc} + optionsLine : String + mainFile : String + mainName : String + moduleHeader : {String -> String -> String -> Bool -> String} + | | ] + +SEM Program + | Program + loc.mainModuleFile = @lhs.mainFile + loc.genMainModule + = writeModule @loc.mainModuleFile + ( [ pp $ @lhs.pragmaBlocks + , pp $ @lhs.optionsLine + , pp $ @lhs.moduleHeader @lhs.mainName "" "" False + , pp $ ("import " ++ @lhs.mainName ++ "_common\n") + ] + ++ map pp @chunks.imports + ++ map vlist @chunks.appendMain + ++ [@lhs.mainBlocksDoc] + ) + + loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") + loc.genCommonModule + = writeModule @loc.commonFile + ( [ pp $ @lhs.pragmaBlocks + , pp $ @lhs.optionsLine + , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True + , @lhs.importBlocks + , @lhs.textBlocks + ] + ++ map vlist @chunks.appendCommon + ) + + lhs.genIO = do @loc.genMainModule + @loc.genCommonModule + @chunks.genSems + +{ +renderDocs :: [PP_Doc] -> String +renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" +} + +ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ] +SEM Chunk + | Chunk + lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"] + +ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ] + +SEM Chunk + | Chunk + lhs.appendCommon + = [ [@comment.pp] + , @dataDef.pps + , @semDom.pps + , if reference @lhs.options then @semWrapper.pps else [] + ] + lhs.appendMain + = [ [@comment.pp] + , @cataFun.pps + , if reference @lhs.options then [] else @semWrapper.pps + ] + +ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ] + +SEM Chunk + | Chunk + lhs.genSems + = writeModule @loc.outputfile + [ pp $ @lhs.pragmaBlocks + , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap + , pp $ @lhs.optionsLine + , pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True + , pp $ ("import " ++ @lhs.mainName ++ "_common\n") + , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap + , @comment.pp + , vlist_sep "" @info.pps + , vlist_sep "" @semFunctions.pps + , Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap + ] + +SEM Chunk + | Chunk + loc.exports = concat $ intersperse "," @semNames + +{ +writeModule :: FilePath -> [PP_Doc] -> IO () +writeModule path docs + = do bExists <- doesFileExist path + if bExists + then do input <- readFile path + seq (length input) (return ()) + if input /= output + then dumpIt + else return () + else dumpIt + where + output = renderDocs docs + dumpIt = writeFile path output +} + diff --git a/src-ag/PrintCode.ag b/src-ag/PrintCode.ag --- a/src-ag/PrintCode.ag +++ b/src-ag/PrintCode.ag @@ -1,542 +1,542 @@ -PRAGMA strictdata -PRAGMA optimize -PRAGMA bangpats -PRAGMA strictwrap - -INCLUDE "Code.ag" -INCLUDE "Patterns.ag" - -imports -{ -import Data.Char (isAlphaNum) -import Pretty -import Code -import Options -import CommonTypes (attrname, _LOC, nullIdent) -import Data.List(intersperse) -import System.IO -import System.Directory -import System.FilePath -import CommonTypes(BlockInfo, BlockKind(..)) -} - -{ -type PP_Docs = [PP_Doc] -} - -{ -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs -} - -ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ] - -SEM Chunk - | Chunk - loc.outputfile = if sepSemMods @lhs.options - then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name) - else @lhs.mainFile - -ATTR Program [ options:{Options} | | output:{PP_Docs} ] - -ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ] - -ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ] - -ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ] - -ATTR CaseAlt CaseAlts [ nested:{Bool} | | pps: {PP_Docs} ] - -SEM Program | Program - loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered } - -SEM Program - | Program chunks.nested = nest @lhs.options - -SEM Exprs - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM CaseAlts - | Cons lhs.pps = @hd.pps ++ @tl.pps - | Nil lhs.pps = [] - -SEM DataAlts - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Types - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM NamedTypes - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Decls - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Chunks - | Cons lhs.pps = @hd.pps ++ @tl.pps - | Nil lhs.pps = [] - - -SEM Program - | Program lhs.output = @chunks.pps - -SEM Chunk - | Chunk lhs.pps = @comment.pp - : @info.pps - ++ @dataDef.pps - ++ @cataFun.pps - ++ @semDom.pps - ++ @semWrapper.pps - ++ @semFunctions.pps - ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap] - -SEM Decl - | Decl lhs.pp = @left.pp >#< "=" - >-< indent 4 @rhs.pp - | Bind lhs.pp = @left.pp >#< "<-" >#< @rhs.pp - | BindLet lhs.pp = "let" >#< @left.pp >#< "=" >#< @rhs.pp - | Data lhs.pp = "data" >#< hv_sp (@name : @params) - >#< ( case @alts.pps of - [] -> empty - (x:xs) -> "=" >#< x - >-< vlist (map ("|" >#<) xs) - >-< if null @derivings - then empty - else "deriving" >#< ppTuple False (map text @derivings) - ) - | NewType lhs.pp = "newtype" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp - | Type lhs.pp = "type" >#< hv_sp (@name : @params) >#< "=" >#< @tp.pp - | TSig lhs.pp = @name >#< "::" >#< @tp.pp - | Comment lhs.pp = if '\n' `elem` @txt - then "{-" >-< vlist (lines @txt) >-< "-}" - else "--" >#< @txt - | PragmaDecl lhs.pp = "{-#" >#< text @txt >#< "#-}" - | Resume lhs.pp = if @monadic - then @left.pp >#< "<-" >#< @rhs.pp - else @left.pp >#< "=" >-< indent 4 @rhs.pp - | EvalDecl loc.strat = if breadthFirstStrict @lhs.options - then "stepwiseEval" - else "lazyEval" - lhs.pp = if breadthFirst @lhs.options - then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of" - >-< indent 4 ( - pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val" - ) - else @left.pp >#< "=" >#< @rhs.pp - -SEM Expr - | Let lhs.pp = pp_parens ( "let" >#< (vlist @decls.pps) - >-< "in " >#< @body.pp - ) - | Case lhs.pp = pp_parens ( "case" >#< pp_parens @expr.pp >#< "of" - >-< (vlist @alts.pps) - ) - | Do lhs.pp = pp_parens ( "do" >#< ( vlist @stmts.pps - >-< ("return" >#< @body.pp)) - ) - | Lambda loc.strictParams = if strictSems @lhs.options - then @args.pps - else [] - loc.addBang = if bangpats @lhs.options - then \p -> pp_parens ("!" >|< p) - else id - lhs.pp = pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->" - >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp) - ) - | TupleExpr lhs.pp = ppTuple @lhs.nested @exprs.pps - | UnboxedTupleExpr lhs.pp = ppUnboxedTuple @lhs.nested @exprs.pps - | App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps - | SimpleExpr lhs.pp = text @txt - | TextExpr lhs.pp = vlist (map text @lns) - | Trace lhs.pp = "trace" >#< ( pp_parens ("\"" >|< text @txt >|< "\"") - >-< pp_parens @expr.pp - ) - | PragmaExpr lhs.pp = let pragmaDoc = "{-#" >#< @txt >#< "#-}" - op = if @onNewLine - then (>-<) - else (>#<) - leftOp x y = if @onLeftSide - then x `op` y - else y - rightOp x y = if @onLeftSide - then x - else x `op` y - in pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc) - | LineExpr lhs.pp = @expr.pp >-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#-}" - >-< "" - | TypedExpr lhs.pp = pp_parens (@expr.pp >#< "::" >#< @tp.pp) - | ResultExpr lhs.pp = if breadthFirst @lhs.options - then "final" >#< - pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp) - else @expr.pp - | InvokeExpr lhs.pp = if breadthFirst @lhs.options - then "invoke" >#< pp_parens @expr.pp >#< pp_parens ( - @nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps)) - else @expr.pp >#< hv_sp @args.pps - | ResumeExpr lhs.pp = if breadthFirst @lhs.options - then pp_parens ("resume" >#< pp_parens @expr.pp - >-< indent 2 (pp_parens ( "\\" >|< - pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg")) - >#< "->" - >-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg" - >-< indent 2 ("in" >#< @rhs.pp) - )))) - else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of" - >-< ("{" >#< @left.pp >#< "->") - >-< indent 4 (@rhs.pp >#< "}") - ) - | SemFun loc.strictParams = if strictSems @lhs.options - then @args.pps - else [] - loc.addBang = if bangpats @lhs.options - then \p -> pp_parens ("!" >|< p) - else id - lhs.pp = if breadthFirst @lhs.options - then "Child" >#< pp_parens ( "\\" >|< - pp_parens (@nt >|< "_Inh" >#< - ppTuple False (map @loc.addBang @args.pps)) >#< "->" - >-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp)) - else if null @args.pps - then @body.pp - else pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->" - >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp) - ) - -SEM CaseAlt - | CaseAlt lhs.pps = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"] - -SEM DataAlt - | DataAlt lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) - | Record lhs.pp = @name >#< pp_block "{" "}" "," @args.pps - -SEM NamedType - | Named lhs.pp = if @strict - then @name >#< "::" >#< "!" >|< pp_parens @tp.pp - else @name >#< "::" >#< @tp.pp - -SEM Lhs - | Pattern3 TupleLhs UnboxedTupleLhs - loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id - | Pattern3 - loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True") - loc.hasStrictVars = not (null @pat3.strictVars) - | TupleLhs UnboxedTupleLhs - loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet - then map text @comps `ppMultiSeqH` (pp "True") - else pp "True" - loc.hasStrictVars = not (null @comps) - - | Fun - loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id - loc.hasStrictVars = not (null @args.pps) - loc.strictGuard = @args.pps `ppMultiSeqH` (pp "True") - - | TupleLhs UnboxedTupleLhs Fun - loc.addBang = if bangpats @lhs.options - then \p -> "!" >|< p - else id - - | Pattern3 lhs.pp = @loc.addStrictGuard @pat3.pp - | Pattern3SM lhs.pp = @pat3.pp' - | TupleLhs lhs.pp = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps) - | UnboxedTupleLhs lhs.pp = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps) - | Fun lhs.pp = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps)) - | Unwrap lhs.pp = pp_parens (@name >#< @sub.pp) - -SEM Type [ | | prec:Int ] - | Arr lhs.prec = 2 - .pp = @loc.l >#< "->" >-< @loc.r - loc.l = if @left.prec <= 2 then pp_parens @left.pp else @left.pp - .r = if @right.prec < 2 then pp_parens @right.pp else @right.pp - - | TypeApp - lhs.pp = hv_sp (@func.pp : @args.pps) - - | CtxApp - lhs.pp = (pp_block "(" ")" "," $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left) >#< "=>" >#< @right.pp - | QuantApp - lhs.pp = @left >#< @right.pp - - | TupleType lhs.prec = 5 - .pp = ppTuple @lhs.nested @tps.pps - - | UnboxedTupleType lhs.prec = 5 - .pp = ppUnboxedTuple @lhs.nested @tps.pps - - | List lhs.prec = 5 - .pp = "[" >|< @tp.pp >|< "]" - - | SimpleType lhs.prec = 5 - .pp = if reallySimple @txt then text @txt else pp_parens (text @txt) - - | NontermType lhs.prec = 5 - lhs.pp = @loc.prefix >|< text @name >#< hv_sp @params - loc.prefix = if @deforested - then text "T_" - else empty - | TMaybe lhs.prec = 5 - lhs.pp = text "Maybe" >#< pp_parens @tp.pp - | TEither lhs.prec = 5 - lhs.pp = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp - | TMap lhs.prec = 5 - lhs.pp = text "Data.Map.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp - | TIntMap lhs.prec = 5 - lhs.pp = text "Data.IntMap.IntMap" >#< pp_parens @value.pp - | TSet lhs.prec = 5 - lhs.pp = text "Data.Set.Set" >#< pp_parens @tp.pp - | TIntSet lhs.prec = 5 - lhs.pp = text "Data.IntSet.IntSet" - - -{ - -reallySimple :: String -> Bool -reallySimple = and . map (\x -> isAlphaNum x || x=='_') - -ppTuple :: Bool -> [PP_Doc] -> PP_Doc -ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps -ppTuple False pps = "(" >|< pp_block " " ")" "," pps -ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc -ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps -ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps - -} - - -------------------------------------------------------------------------------- --- Strict data fields -------------------------------------------------------------------------------- - -ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ] - -SEM Decl - | Data alts.strictPre = if @strict then pp "!" else empty - -------------------------------------------------------------------------------- --- Strict variables -------------------------------------------------------------------------------- - -ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ] -SEM Pattern - | Alias - loc.strictVar - = if strictCases @lhs.options && not @lhs.isDeclOfLet - then [@loc.ppVar] - else [] - loc.strictPatVars - = if stricterCases @lhs.options && not @lhs.isDeclOfLet - then @pat.strictVars - else [] - lhs.strictVars - = @loc.strictVar ++ @loc.strictPatVars - | Irrefutable - lhs.strictVars = [] - -------------------------------------------------------------------------------- --- Pretty printing patterns -------------------------------------------------------------------------------- - -SEM Patterns [ | | pps : {[PP_Doc]} ] - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Pattern - | Constr Product Alias - loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable - then \p -> "!" >|< p - else id - -SEM Pattern [ | | pp:PP_Doc ] - | Constr lhs.pp = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps - | Product lhs.pp = @loc.addBang $ pp_block "(" ")" "," @pats.pps - | Alias loc.ppVar = pp (attrname @lhs.options False @field @attr) - loc.ppVarBang = @loc.addBang $ @loc.ppVar - lhs.pp = if @pat.isUnderscore - then @loc.ppVarBang - else @loc.ppVarBang >|< "@" >|< @pat.pp - | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp - | Underscore lhs.pp = text "_" - -SEM Pattern [ | | isUnderscore:{Bool}] - | Constr lhs.isUnderscore = False - | Product lhs.isUnderscore = False - | Alias lhs.isUnderscore = False - | Underscore lhs.isUnderscore = True - -ATTR Pattern Patterns [ belowIrrefutable : Bool | | ] -SEM Pattern - | Irrefutable - pat.belowIrrefutable = True - -SEM Lhs - | Pattern3 Pattern3SM - pat3.belowIrrefutable = False - -------------------------------------------------------------------------------- --- Pretty printing patterns for SM -------------------------------------------------------------------------------- - -SEM Patterns [ | | pps' : {[PP_Doc]} ] - | Cons lhs.pps' = @hd.pp' : @tl.pps' - | Nil lhs.pps' = [] - -SEM Pattern [ | | pp':PP_Doc ] - | Constr lhs.pp' = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps') - | Product lhs.pp' = pp_block "(" ")" "," @pats.pps' - | Alias lhs.pp' = let attribute | @field == _LOC || @field == nullIdent = locname' @attr - | otherwise = attrname @lhs.options False @field @attr - in attribute >|< "@" >|< @pat.pp' - | Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp - | Underscore lhs.pp' = text "_" - -{ -locname' :: Identifier -> [Char] -locname' n = "_loc_" ++ getName n -} - -------------------------------------------------------------------------------- --- Determine if inside a Let -------------------------------------------------------------------------------- - -ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ] -SEM Program - | Program - chunks.isDeclOfLet = False - -SEM Expr - | Let - decls.isDeclOfLet = True - | Do - stmts.isDeclOfLet = False - | ResumeExpr - left.isDeclOfLet = False - -SEM CaseAlt - | CaseAlt - left.isDeclOfLet = False - - - -------------------------------------------------------------------------------- --- Alternative code printing to separate modules -------------------------------------------------------------------------------- - -ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ] -ATTR Program Chunks Chunk - [ importBlocks : PP_Doc - pragmaBlocks : String - textBlocks : PP_Doc - textBlockMap : {Map BlockInfo PP_Doc} - optionsLine : String - mainFile : String - mainName : String - moduleHeader : {String -> String -> String -> Bool -> String} - | | ] - -SEM Program - | Program - loc.mainModuleFile = @lhs.mainFile - loc.genMainModule - = writeModule @loc.mainModuleFile - ( [ pp $ @lhs.pragmaBlocks - , pp $ @lhs.optionsLine - , pp $ @lhs.moduleHeader @lhs.mainName "" "" False - , pp $ ("import " ++ @lhs.mainName ++ "_common\n") - ] - ++ map pp @chunks.imports - ++ map vlist @chunks.appendMain - ++ [@lhs.mainBlocksDoc] - ) - - loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") - loc.genCommonModule - = writeModule @loc.commonFile - ( [ pp $ @lhs.pragmaBlocks - , pp $ @lhs.optionsLine - , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True - , @lhs.importBlocks - , @lhs.textBlocks - ] - ++ map vlist @chunks.appendCommon - ) - - lhs.genIO = do @loc.genMainModule - @loc.genCommonModule - @chunks.genSems - -{ -renderDocs :: [PP_Doc] -> String -renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" -} - -ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ] -SEM Chunk - | Chunk - lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"] - -ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ] - -SEM Chunk - | Chunk - lhs.appendCommon - = [ [@comment.pp] - , @dataDef.pps - , @semDom.pps - , if reference @lhs.options then @semWrapper.pps else [] - ] - lhs.appendMain - = [ [@comment.pp] - , @cataFun.pps - , if reference @lhs.options then [] else @semWrapper.pps - ] - -ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ] - -SEM Chunk - | Chunk - lhs.genSems - = writeModule @loc.outputfile - [ pp $ @lhs.pragmaBlocks - , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap - , pp $ @lhs.optionsLine - , pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True - , pp $ ("import " ++ @lhs.mainName ++ "_common\n") - , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap - , @comment.pp - , vlist_sep "" @info.pps - , vlist_sep "" @semFunctions.pps - , Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap - ] - -SEM Chunk - | Chunk - loc.exports = concat $ intersperse "," @semNames - -{ -writeModule :: FilePath -> [PP_Doc] -> IO () -writeModule path docs - = do bExists <- doesFileExist path - if bExists - then do input <- readFile path - seq (length input) (return ()) - if input /= output - then dumpIt - else return () - else dumpIt - where - output = renderDocs docs - dumpIt = writeFile path output -} - +PRAGMA strictdata +PRAGMA optimize +PRAGMA bangpats +PRAGMA strictwrap + +INCLUDE "Code.ag" +INCLUDE "Patterns.ag" + +imports +{ +import Data.Char (isAlphaNum) +import Pretty +import Code +import Options +import CommonTypes (attrname, _LOC, nullIdent) +import Data.List(intersperse) +import System.IO +import System.Directory +import System.FilePath +import CommonTypes(BlockInfo, BlockKind(..)) +} + +{ +type PP_Docs = [PP_Doc] +} + +{ +ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqH = ppMultiSeq' (>#<) + +ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqV = ppMultiSeq' (>-<) + +ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeq' next strictArgs expr + = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs +} + +ATTR Expr Exprs Decl Decls CaseAlt CaseAlts Lhs [ outputfile : {String} | | ] + +SEM Chunk + | Chunk + loc.outputfile = if sepSemMods @lhs.options + then replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_" ++ @name) + else @lhs.mainFile + +ATTR Program [ options:{Options} | | output:{PP_Docs} ] + +ATTR Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ] + +ATTR Expr Decl DataAlt Type NamedType Lhs [ nested:{Bool} | | pp:{PP_Doc} ] + +ATTR Exprs DataAlts Types NamedTypes Decls Chunk Chunks [ nested:{Bool} | | pps : {PP_Docs} ] + +ATTR CaseAlt CaseAlts [ nested:{Bool} | | pps: {PP_Docs} ] + +SEM Program | Program + loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @ordered } + +SEM Program + | Program chunks.nested = nest @lhs.options + +SEM Exprs + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM CaseAlts + | Cons lhs.pps = @hd.pps ++ @tl.pps + | Nil lhs.pps = [] + +SEM DataAlts + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM Types + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM NamedTypes + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM Decls + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM Chunks + | Cons lhs.pps = @hd.pps ++ @tl.pps + | Nil lhs.pps = [] + + +SEM Program + | Program lhs.output = @chunks.pps + +SEM Chunk + | Chunk lhs.pps = @comment.pp + : @info.pps + ++ @dataDef.pps + ++ @cataFun.pps + ++ @semDom.pps + ++ @semWrapper.pps + ++ @semFunctions.pps + ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap] + +SEM Decl + | Decl lhs.pp = @left.pp >#< "=" + >-< indent 4 @rhs.pp + | Bind lhs.pp = @left.pp >#< "<-" >#< @rhs.pp + | BindLet lhs.pp = "let" >#< @left.pp >#< "=" >#< @rhs.pp + | Data lhs.pp = "data" >#< hv_sp (@name : @params) + >#< ( case @alts.pps of + [] -> empty + (x:xs) -> "=" >#< x + >-< vlist (map ("|" >#<) xs) + >-< if null @derivings + then empty + else "deriving" >#< ppTuple False (map text @derivings) + ) + | NewType lhs.pp = "newtype" >#< hv_sp (@name : @params) >#< "=" >#< @con >#< pp_parens @tp.pp + | Type lhs.pp = "type" >#< hv_sp (@name : @params) >#< "=" >#< @tp.pp + | TSig lhs.pp = @name >#< "::" >#< @tp.pp + | Comment lhs.pp = if '\n' `elem` @txt + then "{-" >-< vlist (lines @txt) >-< "-}" + else "--" >#< @txt + | PragmaDecl lhs.pp = "{-#" >#< text @txt >#< "#-}" + | Resume lhs.pp = if @monadic + then @left.pp >#< "<-" >#< @rhs.pp + else @left.pp >#< "=" >-< indent 4 @rhs.pp + | EvalDecl loc.strat = if breadthFirstStrict @lhs.options + then "stepwiseEval" + else "lazyEval" + lhs.pp = if breadthFirst @lhs.options + then @left.pp >#< "=" >#< "case" >#< @loc.strat >#< pp_parens @rhs.pp >#< "of" + >-< indent 4 ( + pp_parens (@nt >|< "_Syn" >#< "_val") >#< "-> _val" + ) + else @left.pp >#< "=" >#< @rhs.pp + +SEM Expr + | Let lhs.pp = pp_parens ( "let" >#< (vlist @decls.pps) + >-< "in " >#< @body.pp + ) + | Case lhs.pp = pp_parens ( "case" >#< pp_parens @expr.pp >#< "of" + >-< (vlist @alts.pps) + ) + | Do lhs.pp = pp_parens ( "do" >#< ( vlist @stmts.pps + >-< ("return" >#< @body.pp)) + ) + | Lambda loc.strictParams = if strictSems @lhs.options + then @args.pps + else [] + loc.addBang = if bangpats @lhs.options + then \p -> pp_parens ("!" >|< p) + else id + lhs.pp = pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->" + >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp) + ) + | TupleExpr lhs.pp = ppTuple @lhs.nested @exprs.pps + | UnboxedTupleExpr lhs.pp = ppUnboxedTuple @lhs.nested @exprs.pps + | App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps + | SimpleExpr lhs.pp = text @txt + | TextExpr lhs.pp = vlist (map text @lns) + | Trace lhs.pp = "trace" >#< ( pp_parens ("\"" >|< text @txt >|< "\"") + >-< pp_parens @expr.pp + ) + | PragmaExpr lhs.pp = let pragmaDoc = "{-#" >#< @txt >#< "#-}" + op = if @onNewLine + then (>-<) + else (>#<) + leftOp x y = if @onLeftSide + then x `op` y + else y + rightOp x y = if @onLeftSide + then x + else x `op` y + in pp_parens (pragmaDoc `leftOp` @expr.pp `rightOp` pragmaDoc) + | LineExpr lhs.pp = @expr.pp >-< "{-# LINE" >#< ppWithLineNr (\n -> pp $ show $ n + 1) >#< show @lhs.outputfile >#< "#-}" + >-< "" + | TypedExpr lhs.pp = pp_parens (@expr.pp >#< "::" >#< @tp.pp) + | ResultExpr lhs.pp = if breadthFirst @lhs.options + then "final" >#< + pp_parens (@nt >|< "_Syn" >#< pp_parens @expr.pp) + else @expr.pp + | InvokeExpr lhs.pp = if breadthFirst @lhs.options + then "invoke" >#< pp_parens @expr.pp >#< pp_parens ( + @nt >|< "_Inh" >#< pp_parens (ppTuple False @args.pps)) + else @expr.pp >#< hv_sp @args.pps + | ResumeExpr lhs.pp = if breadthFirst @lhs.options + then pp_parens ("resume" >#< pp_parens @expr.pp + >-< indent 2 (pp_parens ( "\\" >|< + pp_parens ("~" >|< pp_parens (@nt >|< "_Syn" >#< "_inh_arg")) + >#< "->" + >-< indent 2 ( "let" >#< @left.pp >#< "= _inh_arg" + >-< indent 2 ("in" >#< @rhs.pp) + )))) + else pp_parens ( "case" >#< pp_parens @expr.pp >#< "of" + >-< ("{" >#< @left.pp >#< "->") + >-< indent 4 (@rhs.pp >#< "}") + ) + | SemFun loc.strictParams = if strictSems @lhs.options + then @args.pps + else [] + loc.addBang = if bangpats @lhs.options + then \p -> pp_parens ("!" >|< p) + else id + lhs.pp = if breadthFirst @lhs.options + then "Child" >#< pp_parens ( "\\" >|< + pp_parens (@nt >|< "_Inh" >#< + ppTuple False (map @loc.addBang @args.pps)) >#< "->" + >-< indent 2 (@loc.strictParams `ppMultiSeqV` @body.pp)) + else if null @args.pps + then @body.pp + else pp_parens ( "\\" >#< (vlist (map @loc.addBang @args.pps)) >#< "->" + >-< indent 4 (@loc.strictParams `ppMultiSeqV` @body.pp) + ) + +SEM CaseAlt + | CaseAlt lhs.pps = ["{" >#< @left.pp >#< "->", @expr.pp >#< "}"] + +SEM DataAlt + | DataAlt lhs.pp = @name >#< hv_sp (map ((@lhs.strictPre >|<) . pp_parens) @args.pps) + | Record lhs.pp = @name >#< pp_block "{" "}" "," @args.pps + +SEM NamedType + | Named lhs.pp = if @strict + then @name >#< "::" >#< "!" >|< pp_parens @tp.pp + else @name >#< "::" >#< @tp.pp + +SEM Lhs + | Pattern3 TupleLhs UnboxedTupleLhs + loc.addStrictGuard = if strictCases @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id + | Pattern3 + loc.strictGuard = @pat3.strictVars `ppMultiSeqH` (pp "True") + loc.hasStrictVars = not (null @pat3.strictVars) + | TupleLhs UnboxedTupleLhs + loc.strictGuard = if stricterCases @lhs.options && not @lhs.isDeclOfLet + then map text @comps `ppMultiSeqH` (pp "True") + else pp "True" + loc.hasStrictVars = not (null @comps) + + | Fun + loc.addStrictGuard = if strictSems @lhs.options && @loc.hasStrictVars then \v -> v >#< "|" >#< @loc.strictGuard else id + loc.hasStrictVars = not (null @args.pps) + loc.strictGuard = @args.pps `ppMultiSeqH` (pp "True") + + | TupleLhs UnboxedTupleLhs Fun + loc.addBang = if bangpats @lhs.options + then \p -> "!" >|< p + else id + + | Pattern3 lhs.pp = @loc.addStrictGuard @pat3.pp + | Pattern3SM lhs.pp = @pat3.pp' + | TupleLhs lhs.pp = @loc.addStrictGuard $ ppTuple @lhs.nested (map (@loc.addBang . text) @comps) + | UnboxedTupleLhs lhs.pp = @loc.addStrictGuard $ ppUnboxedTuple @lhs.nested (map (@loc.addBang . text) @comps) + | Fun lhs.pp = @loc.addStrictGuard (@name >#< hv_sp (map @loc.addBang @args.pps)) + | Unwrap lhs.pp = pp_parens (@name >#< @sub.pp) + +SEM Type [ | | prec:Int ] + | Arr lhs.prec = 2 + .pp = @loc.l >#< "->" >-< @loc.r + loc.l = if @left.prec <= 2 then pp_parens @left.pp else @left.pp + .r = if @right.prec < 2 then pp_parens @right.pp else @right.pp + + | TypeApp + lhs.pp = hv_sp (@func.pp : @args.pps) + + | CtxApp + lhs.pp = (pp_block "(" ")" "," $ map (\(n,ns) -> hv_sp $ map pp (n:ns)) @left) >#< "=>" >#< @right.pp + | QuantApp + lhs.pp = @left >#< @right.pp + + | TupleType lhs.prec = 5 + .pp = ppTuple @lhs.nested @tps.pps + + | UnboxedTupleType lhs.prec = 5 + .pp = ppUnboxedTuple @lhs.nested @tps.pps + + | List lhs.prec = 5 + .pp = "[" >|< @tp.pp >|< "]" + + | SimpleType lhs.prec = 5 + .pp = if reallySimple @txt then text @txt else pp_parens (text @txt) + + | NontermType lhs.prec = 5 + lhs.pp = @loc.prefix >|< text @name >#< hv_sp @params + loc.prefix = if @deforested + then text "T_" + else empty + | TMaybe lhs.prec = 5 + lhs.pp = text "Maybe" >#< pp_parens @tp.pp + | TEither lhs.prec = 5 + lhs.pp = text "Either" >#< pp_parens @left.pp >#< pp_parens @right.pp + | TMap lhs.prec = 5 + lhs.pp = text "Data.Map.Map" >#< pp_parens @key.pp >#< pp_parens @value.pp + | TIntMap lhs.prec = 5 + lhs.pp = text "Data.IntMap.IntMap" >#< pp_parens @value.pp + | TSet lhs.prec = 5 + lhs.pp = text "Data.Set.Set" >#< pp_parens @tp.pp + | TIntSet lhs.prec = 5 + lhs.pp = text "Data.IntSet.IntSet" + + +{ + +reallySimple :: String -> Bool +reallySimple = and . map (\x -> isAlphaNum x || x=='_') + +ppTuple :: Bool -> [PP_Doc] -> PP_Doc +ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps +ppTuple False pps = "(" >|< pp_block " " ")" "," pps +ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc +ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps +ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps + +} + + +------------------------------------------------------------------------------- +-- Strict data fields +------------------------------------------------------------------------------- + +ATTR DataAlt DataAlts [ strictPre: PP_Doc | | ] + +SEM Decl + | Data alts.strictPre = if @strict then pp "!" else empty + +------------------------------------------------------------------------------- +-- Strict variables +------------------------------------------------------------------------------- + +ATTR Pattern Patterns [ | | strictVars USE {++} {[]} : {[PP_Doc]} ] +SEM Pattern + | Alias + loc.strictVar + = if strictCases @lhs.options && not @lhs.isDeclOfLet + then [@loc.ppVar] + else [] + loc.strictPatVars + = if stricterCases @lhs.options && not @lhs.isDeclOfLet + then @pat.strictVars + else [] + lhs.strictVars + = @loc.strictVar ++ @loc.strictPatVars + | Irrefutable + lhs.strictVars = [] + +------------------------------------------------------------------------------- +-- Pretty printing patterns +------------------------------------------------------------------------------- + +SEM Patterns [ | | pps : {[PP_Doc]} ] + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM Pattern + | Constr Product Alias + loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable + then \p -> "!" >|< p + else id + +SEM Pattern [ | | pp:PP_Doc ] + | Constr lhs.pp = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps + | Product lhs.pp = @loc.addBang $ pp_block "(" ")" "," @pats.pps + | Alias loc.ppVar = pp (attrname @lhs.options False @field @attr) + loc.ppVarBang = @loc.addBang $ @loc.ppVar + lhs.pp = if @pat.isUnderscore + then @loc.ppVarBang + else @loc.ppVarBang >|< "@" >|< @pat.pp + | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp + | Underscore lhs.pp = text "_" + +SEM Pattern [ | | isUnderscore:{Bool}] + | Constr lhs.isUnderscore = False + | Product lhs.isUnderscore = False + | Alias lhs.isUnderscore = False + | Underscore lhs.isUnderscore = True + +ATTR Pattern Patterns [ belowIrrefutable : Bool | | ] +SEM Pattern + | Irrefutable + pat.belowIrrefutable = True + +SEM Lhs + | Pattern3 Pattern3SM + pat3.belowIrrefutable = False + +------------------------------------------------------------------------------- +-- Pretty printing patterns for SM +------------------------------------------------------------------------------- + +SEM Patterns [ | | pps' : {[PP_Doc]} ] + | Cons lhs.pps' = @hd.pp' : @tl.pps' + | Nil lhs.pps' = [] + +SEM Pattern [ | | pp':PP_Doc ] + | Constr lhs.pp' = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps') + | Product lhs.pp' = pp_block "(" ")" "," @pats.pps' + | Alias lhs.pp' = let attribute | @field == _LOC || @field == nullIdent = locname' @attr + | otherwise = attrname @lhs.options False @field @attr + in attribute >|< "@" >|< @pat.pp' + | Irrefutable lhs.pp' = text "~" >|< pp_parens @pat.pp + | Underscore lhs.pp' = text "_" + +{ +locname' :: Identifier -> [Char] +locname' n = "_loc_" ++ getName n +} + +------------------------------------------------------------------------------- +-- Determine if inside a Let +------------------------------------------------------------------------------- + +ATTR Chunks Chunk Decls Decl Lhs Pattern Patterns [ isDeclOfLet : Bool | | ] +SEM Program + | Program + chunks.isDeclOfLet = False + +SEM Expr + | Let + decls.isDeclOfLet = True + | Do + stmts.isDeclOfLet = False + | ResumeExpr + left.isDeclOfLet = False + +SEM CaseAlt + | CaseAlt + left.isDeclOfLet = False + + + +------------------------------------------------------------------------------- +-- Alternative code printing to separate modules +------------------------------------------------------------------------------- + +ATTR Program [ mainBlocksDoc : PP_Doc | | genIO : {IO ()} ] +ATTR Program Chunks Chunk + [ importBlocks : PP_Doc + pragmaBlocks : String + textBlocks : PP_Doc + textBlockMap : {Map BlockInfo PP_Doc} + optionsLine : String + mainFile : String + mainName : String + moduleHeader : {String -> String -> String -> Bool -> String} + | | ] + +SEM Program + | Program + loc.mainModuleFile = @lhs.mainFile + loc.genMainModule + = writeModule @loc.mainModuleFile + ( [ pp $ @lhs.pragmaBlocks + , pp $ @lhs.optionsLine + , pp $ @lhs.moduleHeader @lhs.mainName "" "" False + , pp $ ("import " ++ @lhs.mainName ++ "_common\n") + ] + ++ map pp @chunks.imports + ++ map vlist @chunks.appendMain + ++ [@lhs.mainBlocksDoc] + ) + + loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") + loc.genCommonModule + = writeModule @loc.commonFile + ( [ pp $ @lhs.pragmaBlocks + , pp $ @lhs.optionsLine + , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True + , @lhs.importBlocks + , @lhs.textBlocks + ] + ++ map vlist @chunks.appendCommon + ) + + lhs.genIO = do @loc.genMainModule + @loc.genCommonModule + @chunks.genSems + +{ +renderDocs :: [PP_Doc] -> String +renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" +} + +ATTR Chunk Chunks [ | | imports USE {++} {[]} : {[String]} ] +SEM Chunk + | Chunk + lhs.imports = ["import " ++ @lhs.mainName ++ "_" ++ @name ++ "\n"] + +ATTR Chunk Chunks [ | | appendCommon, appendMain USE {++} {[]} : {[[PP_Doc]]} ] + +SEM Chunk + | Chunk + lhs.appendCommon + = [ [@comment.pp] + , @dataDef.pps + , @semDom.pps + , if reference @lhs.options then @semWrapper.pps else [] + ] + lhs.appendMain + = [ [@comment.pp] + , @cataFun.pps + , if reference @lhs.options then [] else @semWrapper.pps + ] + +ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ] + +SEM Chunk + | Chunk + lhs.genSems + = writeModule @loc.outputfile + [ pp $ @lhs.pragmaBlocks + , pp $ Map.findWithDefault empty (BlockPragma, Just $ identifier @name) @lhs.textBlockMap + , pp $ @lhs.optionsLine + , pp $ @lhs.moduleHeader @lhs.mainName ("_" ++ @name) @loc.exports True + , pp $ ("import " ++ @lhs.mainName ++ "_common\n") + , pp $ Map.findWithDefault empty (BlockImport, Just $ identifier @name) @lhs.textBlockMap + , @comment.pp + , vlist_sep "" @info.pps + , vlist_sep "" @semFunctions.pps + , Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap + ] + +SEM Chunk + | Chunk + loc.exports = concat $ intersperse "," @semNames + +{ +writeModule :: FilePath -> [PP_Doc] -> IO () +writeModule path docs + = do bExists <- doesFileExist path + if bExists + then do input <- readFile path + seq (length input) (return ()) + if input /= output + then dumpIt + else return () + else dumpIt + where + output = renderDocs docs + dumpIt = writeFile path output +} + diff --git a/src-ag/PrintErrorMessages.ag b/src-ag/PrintErrorMessages.ag --- a/src-ag/PrintErrorMessages.ag +++ b/src-ag/PrintErrorMessages.ag @@ -1,656 +1,656 @@ -INCLUDE "ErrorMessages.ag" - -imports -{ -import UU.Scanner.Position(Pos(..), noPos) -import ErrorMessages -import Data.List(mapAccumL) -import GrammarInfo -import qualified Control.Monad.Error.Class as Err -} - - -{ -instance Err.Error Error where - noMsg = Err.strMsg "error" - strMsg = CustomError False noPos . pp -} - - -{ -isError :: Options -> Error -> Bool -isError _ (ParserError _ _ _ ) = True -isError _ (DupAlt _ _ _ ) = False -isError _ (DupSynonym _ _ ) = False -isError _ (DupSet _ _ ) = False -isError _ (DupInhAttr _ _ _ ) = True -isError _ (DupSynAttr _ _ _ ) = True -isError _ (DupChild _ _ _ _ ) = False -isError _ (DupRule _ _ _ _ _) = True -isError _ (DupSig _ _ _ ) = False -isError _ (UndefNont _ ) = True -isError _ (UndefAlt _ _ ) = True -isError _ (UndefChild _ _ _ ) = True -isError _ (MissingRule _ _ _ _ ) = False -isError _ (SuperfluousRule _ _ _ _ ) = False -isError _ (UndefLocal _ _ _ ) = True -isError _ (ChildAsLocal _ _ _ ) = False -isError _ (UndefAttr _ _ _ _ _) = True -isError _ (CyclicSet _ ) = True -isError _ (CustomError w _ _ ) = not w -isError opts (LocalCirc _ _ _ _ _) = cycleIsDangerous opts -isError opts (InstCirc _ _ _ _ _) = cycleIsDangerous opts -isError opts (DirectCirc _ _ _ ) = cycleIsDangerous opts -isError opts (InducedCirc _ _ _ ) = cycleIsDangerous opts -isError _ (MissingTypeSig _ _ _ ) = False -isError _ (MissingInstSig _ _ _ ) = True -isError _ (DupUnique _ _ _ ) = False -isError _ (MissingUnique _ _ ) = True -isError _ (MissingSyn _ _ ) = True -isError _ (MissingNamedRule _ _ _) = True -isError _ (DupRuleName _ _ _) = True -isError _ (HsParseError _ _) = True -isError _ (Cyclic _ _ _) = True -isError _ (IncompatibleVisitKind _ _ _ _) = True -isError _ (IncompatibleRuleKind _ _) = True -isError _ (IncompatibleAttachKind _ _) = True - -cycleIsDangerous :: Options -> Bool -cycleIsDangerous opts - = any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ] -} - - - - - - -ATTR Error [ options:{Options} verbose:{Bool} | | pp :{PP_Doc} - me :SELF - ] - -ATTR Errors [ options:{Options} dups : {[String]} | | pp USE {>-<} {text ""} : {PP_Doc} - ] - -SEM Errors - | * loc.verbose = verbose @lhs.options - | Cons loc.str = disp @hd.pp 5000 "" - - lhs.pp = if @loc.str `elem` @lhs.dups - then @tl.pp - else @hd.pp >-< @tl.pp - tl.dups = @loc.str : @lhs.dups - | Nil lhs.pp = text "" - - -SEM Error - | ParserError lhs.pp = let mesg = text ("parser expecting " ++ @problem) - pat = text "" - help = text "" - act = text @action - in ppError (isError @lhs.options @me) @pos mesg pat help act @lhs.verbose - - | HsParseError lhs.pp = ppError True @pos (text @msg) (text "") (text "") (text "Correct the syntax of the Haskell code.") @lhs.verbose - - | DupAlt lhs.pp = let mesg = wfill ["Repeated definition for alternative", getName @con - ,"of nonterminal", getName @nt, "." - ] >-< - wfill ["First definition:", (showPos @occ1),"."] >-< - wfill ["Other definition:", (showPos @con),"."] - pat = "DATA" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< "...") - >-< indent 2 ("|" >#< getName @con >#< "...") - - help = wfill ["The nonterminal",getName @nt,"has more than one alternative that" - ,"is labelled with the constructor name",getName @con,"." - ,"You should either rename or remove enough of them to make all" - ,"constructors of",getName @nt,"uniquely named." - ] - - act = wfill [ "The first alternative of name",getName @con - ,"you have given for nonterminal",getName @nt - ,"is considered valid. All other alternatives have been discarded." - ] - - in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose - - | DupSynonym lhs.pp = let mesg = wfill ["Definition of type synonym", getName @nt, "clashes with another" - ,"type synonym." - ] >-< - wfill ["First definition:", (showPos @occ1),"."] >-< - wfill ["Type synonym :" , (showPos @nt),"."] - pat = "DATA" >#< getName @nt - >-< indent 2 ("|" >#< "...") - >-< "TYPE" >#< getName @nt >#< "=" >#< "..." - help = wfill ["A type synonym with name", getName @nt - ,"has been given while there already is TYPE" - ,"definition with the same name." - ,"You should either rename or remove the type synonym." - ] - act = wfill [ "The clashing type synonym will be ignored." - ] - in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose - - | DupSet lhs.pp = let mesg = wfill ["Definition of nonterminal set", getName @name, "clashes with another" - ,"set, a type synonym or a data definition." - ] >-< - wfill ["First definition:", (showPos @occ1),"."] >-< - wfill ["Set definition:" , (showPos @name),"."] - pat = "SET" >#< getName @name >#< "=" >#< "..." - >-< "SET" >#< getName @name >#< "=" >#< "..." - help = wfill ["A nonterminal set with name", getName @name - ,"has been given while there already is a SET, DATA, or TYPE" - ,"definition with the same name." - ,"You should either rename or remove the nonterminal set." - ] - act = wfill [ "The clashing nonterminal set will be ignored." - ] - in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose - - | DupInhAttr lhs.pp = let mesg = wfill ["Repeated declaration of inherited attribute", getName @attr - , "of nonterminal", getName @nt, "." - ] >-< - wfill ["First definition:", (showPos @occ1),"."] >-< - wfill ["Other definition:", (showPos @attr),"."] - pat = "ATTR" >#< getName @nt >#< "[" >#< getName @attr >|< ":...," - >#< getName @attr >|< ":... | | ]" - - help = wfill ["The identifier" , getName @attr ,"has been declared" - ,"as an inherited (or chained) attribute for nonterminal" - ,getName @nt , "more than once, with possibly different types." - ,"Delete all but one or rename them to make them unique." - ] - act = wfill ["One declaration with its corresponding type is considered valid." - ,"All others have been discarded. The generated program will probably not run." - ] - - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | DupSynAttr lhs.pp = let mesg = wfill ["Repeated declaration of synthesized attribute", getName @attr - , "of nonterminal", getName @nt, "." - ] >-< - wfill ["First definition:", (showPos @occ1),"."] >-< - wfill ["Other definition:", (showPos @attr),"."] - pat = "ATTR" >#< getName @nt >#< "[ | |" >#< getName @attr >|< ":...," - >#< getName @attr >|< ":... ]" - - help = wfill ["The identifier" , getName @attr ,"has been declared" - ,"as a synthesized (or chained) attribute for nonterminal" - ,getName @nt , "more than once, with possibly different types." - ,"Delete all but one or rename them to make them unique." - ] - act = wfill ["One declaration with its corresponding type is considered valid." - ,"All others have been discarded. The generated program will probably not run." - ] - - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | DupChild lhs.pp = let mesg = wfill ["Repeated declaration for field", getName @name, "of alternative" - ,getName @con, "of nonterminal", getName @nt, "." - ] >-< - wfill ["First definition:", (showPos @occ1),"."] >-< - wfill ["Other definition:", (showPos @name),"."] - pat = "DATA" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< (getName @name >|< ":..." >-< getName @name >|< ":...")) - - - help = wfill ["The alternative" ,getName @con , "of nonterminal" ,getName @nt - ,"has more than one field that is named" - , getName @name ++ ". Possibly they have different types." - ,"You should either rename or remove enough of them to make all fields of" - ,getName @con , "for nonterminal " , getName @nt , "uniquely named." - ] - act = wfill ["The last declaration with its corresponding type is considered valid." - ,"All others have been discarded." - ] - in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose - - | DupRule lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rules for" - ,showAttrDef @field @attr,"." - ] >-< - wfill ["First rule:", (showPos @occ1),"."] >-< - wfill ["Other rule:", (showPos @attr),"."] - - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") - >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") - - help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt - ,", there is more than one rule for the" , showAttrDef @field @attr - ,". You should either rename or remove enough of them to make all rules for alternative" - ,getName @con , "of nonterminal " ,getName @nt , "uniquely named." - ] - act = wfill ["The last rule given is considered valid. All others have been discarded."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | DupRuleName lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rule names for" - ,show @nm,"." - ] - - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...") - >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...") - - help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt - ,", there is more than one rule name " , show @nm - ,". You should either rename or remove enough of them." - ] - act = wfill ["Compilation cannot continue."] - in ppError (isError @lhs.options @me) (getPos @nm) mesg pat help act @lhs.verbose - - | DupSig lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more typesignatures for" - ,showAttrDef _LOC @attr,"." - ] >-< - wfill ["First signature:", (showPos @attr),"."] - - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...") - >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...") - - help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt - ,", there is more than one rule for the" , showAttrDef _LOC @attr - ,". You should remove enough of them to make all typesignatures for alternative" - ,getName @con , "of nonterminal " ,getName @nt , "unique." - ] - act = wfill ["The last typesignature given is considered valid. All others have been discarded."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | UndefNont lhs.pp = let mesg = wfill ["Nonterminal", getName @nt, "is not defined." - ] - pat = "DATA" >#< getName @nt >#< "..." - - help = wfill ["There are attributes and/or rules for nonterminal" , getName @nt ,", but there is no definition" - , "for" ,getName @nt, ". Maybe you misspelled it? Otherwise insert a definition." - ] - act = wfill ["Everything regarding the unknown nonterminal has been ignored."] - in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose - - | UndefAlt lhs.pp = let mesg = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt, "is not defined." - ] - pat = "DATA" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< "...") - - help = wfill ["There are rules for alternative", getName @con , "of nonterminal" ,getName @nt - ,", but there is no definition for this alternative in the definitions of the" - ,"nonterminal" , getName @nt, ". Maybe you misspelled it? Otherwise insert a definition." - ] - act = wfill ["All rules for the unknown alternative have been ignored."] - in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose - - | UndefChild lhs.pp = let mesg = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt - , "does not have a nontrivial field named", getName @name , "." - ] - pat = "SEM" >#< @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr @name (identifier "") >#< "= ...") - - help = wfill ["There are rules that define or use attributes of field" , getName @name - ,"in alternative" , getName @con , "of nonterminal" , getName @nt - ,", but there is no field with AG-type in the definition of the alternative." - ,"Maybe you misspelled it? Otherwise insert the field into the definition," - ,"or change its type from an HS-type to an AG-type." - ] - act = wfill ["All rules for the unknown field have been ignored."] - in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose - - | MissingRule lhs.pp = let mesg = wfill ["Missing rule for", showAttrDef @field @attr , "in alternative" - , getName @con , "of nonterminal",getName @nt ,"." - ] - pat = "SEM" >#< @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") - - help = wfill ["The", showAttrDef @field @attr, "in alternative", getName @con - , "of nonterminal", getName @nt, "is missing and cannot be inferred" - ,"by a copy rule, so you should add an appropriate rule." - ] - act = wfill ["The value of the attribute has been set to undefined."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | MissingNamedRule lhs.pp = let mesg = wfill ["Missing rule name ", show @name , "in alternative" - , getName @con , "of nonterminal",getName @nt ,"." - ] - pat = "SEM" >#< @nt - >-< indent 2 ("|" >#< getName @con >#< show @name >#< ": ... = ...") - - help = wfill ["There is a dependency on a rule with name ", show @name , "in alternative" - , getName @con , "of nonterminal",getName @nt ,", but no rule has been defined with this name. Maybe you misspelled it?" - ] - act = wfill ["Compilation cannot continue."] - in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose - - | SuperfluousRule lhs.pp = let mesg = wfill ["Rule for non-existing", showAttrDef @field @attr , "at alternative" - , getName @con , "of nonterminal",getName @nt, "." - ] - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") - - - help = wfill ["There is a rule for" , showAttrDef @field @attr , "in the definitions for alternative" , getName @con - ,"of nonterminal" , getName @nt, ", but this attribute does not exist. Maybe you misspelled it?" - ,"Otherwise either remove the rule or add an appropriate attribute definition." - ] - act = wfill ["The rule has been ignored."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | UndefLocal lhs.pp = let mesg = wfill ["Undefined local variable or field",getName @var, "at constructor" - , getName @con , "of nonterminal",getName @nt, "." - ] - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< ". = " - >#< "..." >#< "@" >|< getName @var >#< "..." ) - - help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal" - , getName @nt , "contains a local variable or field name that is not defined. " - ,"Maybe you misspelled it?" - ,"Otherwise either remove the rule or add an appropriate definition." - ] - act = wfill ["The generated program will not run."] - in ppError (isError @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose - - | ChildAsLocal lhs.pp = let mesg = wfill ["Nontrivial field ",getName @var, "is used as local at constructor" - , getName @con , "of nonterminal",getName @nt, "." - ] - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< "... = " - >#< "..." >#< "@" >|< getName @var >#< "..." ) - - help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal" - , getName @nt , "contains a nontrivial field name", getName @var, "." - ,"You should use @", getName @var, ".self instead, where self is a SELF-attribute." - ] - act = wfill ["The generated program probably contains a type error or has undefined variables."] - in ppError (isError @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose - - | UndefAttr lhs.pp = let mesg = wfill ["Undefined" - , if @isOut - then showAttrDef @field @attr - else showAttrUse @field @attr - , "at constructor" - , getName @con , "of nonterminal",getName @nt, "." - ] - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< ". = " - >#< "..." >#< ppAttrUse @field @attr >#< "...") - - help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal" - ,getName @nt , "contains an attribute that is not defined" - ,"Maybe you misspelled it?" - ,"Otherwise either remove the rule or add an appropriate attribute definition." - ] - act = wfill ["The generated program will not run."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | CyclicSet lhs.pp = let mesg = wfill ["Cyclic definition for nonterminal set", getName @name] - pat = "SET" >#< getName @name >#< "=" >#< "..." >#< getName @name >#< "..." - help = wfill ["The defintion for a nonterminal set named" , getName @name - ,"directly or indirectly refers to itself." - ,"Adapt the definition of the nonterminal set, to remove the cyclic dependency." - ] - act = wfill ["The nonterminal set", getName @name, "is considered to be empty."] - in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose - - | Cyclic lhs.pp = let pos = getPos @nt - mesg = text "Circular dependency for nonterminal" >#< getName @nt - >#< ( case @mbCon of - Nothing -> empty - Just con -> text "and constructor" >#< con - ) - >#< ( case @verts of - v : _ -> text "including vertex" >#< text v - _ -> empty - ) - pat = text "cyclic rule definition" - help = hlist (text "The following attributes are all cyclic: " : map text @verts) - act = wfill ["code cannot be generated until the cycle is removed."] - in ppError (isError @lhs.options @me) pos mesg pat help act False - - | CustomError lhs.pp = let pat = text "unknown" - help = wfill ["not available."] - act = wfill ["unknown"] - in ppError (isError @lhs.options @me) @pos @mesg pat help act False - - | LocalCirc lhs.pp = let mesg = wfill ["Circular dependency for local attribute", getName @attr - , "of alternative", getName @con, "of nonterminal", getName @nt] - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< "loc." >|< getName @attr >#< "=" - >#< "..." >#< "@loc." >|< getName @attr >#< "...") - help = if null @path - then text "the definition is directly circular" - else hlist ("The following attributes are involved in the cycle:": @path) - act | @o_visit = text "An unoptimized version was generated. It might hang when run." - | otherwise = text "The generated program might hang when run." - in ppError (isError @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose - - | InstCirc lhs.pp = let mesg = wfill ["Circular dependency for inst attribute", getName @attr - , "of alternative", getName @con, "of nonterminal", getName @nt] - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< "inst." >|< getName @attr >#< "=" - >#< "..." >#< "@s." >#< "...") - help = if null @path - then text "the definition is directly circular" - else hlist ("The following attributes are involved in the cycle:": @path) - act | @o_visit = text "An unoptimized version was generated. It might hang when run." - | otherwise = text "The generated program might hang when run." - in ppError (isError @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose - - | DirectCirc lhs.pp = let mesg = wfill ["In nonterminal", getName @nt, "synthesized and inherited attributes are mutually dependent" ] - >-< vlist (map showEdge @cyclic) - pat = text "" - help = vlist (map showEdgeLong @cyclic) - act | @o_visit = text "An unoptimized version was generated. It might hang when run." - | otherwise = text "The generated program might hang when run." - in ppError (isError @lhs.options @me) noPos mesg pat help act @lhs.verbose - - | InducedCirc lhs.pp = let mesg = wfill ["After scheduling, in nonterminal", getName @nt, "synthesized and inherited attributes have an INDUCED mutual dependency" ] - >-< vlist (map showEdge @cyclic) - pat = text "" - showInter (CInterface segs) = concat (snd (mapAccumL (\i c -> (succ i :: Integer,("visit " ++ show i) : map ind (showsSegment c))) 0 segs)) - help = vlist (("Interface for nonterminal " ++ getName @nt ++ ":") : map ind (showInter @cinter)) - >-< vlist (map showEdgeLong @cyclic) - act = text "An unoptimized version was generated. It might hang when run." - in ppError (isError @lhs.options @me) noPos mesg pat help act @lhs.verbose - - | MissingTypeSig lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _LOC @attr , "in alternative" - , getName @con , "of nonterminal",getName @nt ,"." - ]>-< - wfill ["Location:", (showPos @attr),"."] - pat = "SEM" >#< @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< ": ...") - help = wfill ["The", showAttrDef _LOC @attr, "in alternative", getName @con - ,"of nonterminal", getName @nt, "is needed in two separate visits to", getName @nt - ,"so its type is needed to generate type signatures." - ,"Please supply its type." - ] - act = wfill ["The type signatures of semantic functions are not generated."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | MissingInstSig lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _INST @attr , "in alternative" - , getName @con , "of nonterminal",getName @nt ,"." - ]>-< - wfill ["Location:", (showPos @attr),"."] - pat = "SEM" >#< @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr _INST @attr >#< ": ...") - help = wfill ["The", showAttrDef _INST @attr, "in alternative", getName @con - ,"of nonterminal", getName @nt, "is a non-terminal attribute, so " - ,"its type is needed to attribute its value." - ,"Please supply its type." - ] - act = wfill ["It is not possible to proceed without this signature."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | MissingUnique lhs.pp = let mesg = wfill ["Missing unique counter (chained attribute)" - , getName @attr - , "at nonterminal" - , getName @nt, "." - ] - pat = "ATTR" >#< getName @nt >#< "[ |" >#< getName @attr >#< " : ... | ]" - - help = wfill ["A unique attribute signature in a constructor for nonterminal" , getName @nt - , "refers to an unique counter (chained attribute) named " - , getName @attr - ,"Maybe you misspelled it?" - ,"Otherwise either remove the signature or add an appropriate attribute definition." - ] - act = wfill ["It is not possible to proceed without this declaration."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | DupUnique lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more unique-attribute signatures for" - ,showAttrDef _LOC @attr,"." - ] >-< - wfill ["First signature:", (showPos @attr),"."] - - pat = "SEM" >#< getName @nt - >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...") - >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...") - - help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt - ,", there is more than one unique-attribute signature for the" , showAttrDef _LOC @attr - ,". You should remove enough of them to make all unique-signatures for alternative" - ,getName @con , "of nonterminal " ,getName @nt , "unique." - ] - act = wfill ["Unpredicatable sharing of unique numbers may occur."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - - | MissingSyn lhs.pp = let mesg = wfill ["Missing synthesized attribute" - , getName @attr - , "at nonterminal" - , getName @nt, "." - ] - pat = "ATTR" >#< getName @nt >#< "[ | | " >#< getName @attr >#< " : ... ]" - - help = wfill ["An augment rule for a constructor for nonterminal" , getName @nt - , "refers to a synthesized attribute named " - , getName @attr - ,"Maybe you misspelled it?" - ,"Otherwise add an appropriate attribute definition." - ] - act = wfill ["It is not possible to proceed without this declaration."] - in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose - | IncompatibleVisitKind - lhs.pp = let mesg = "visit" >#< @vis >#< "of child" >#< @child >#< " with kind" >#< show @to >#< " cannot be called from a visit with kind " >#< show @from - pat = empty - help = empty - act = text "It is not possible to proceed without fixing this kind error." - in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose - | IncompatibleRuleKind - lhs.pp = let mesg = "rule" >#< @rule >#< "cannot be called from a visit with kind " >#< show @kind - pat = empty - help = empty - act = text "It is not possible to proceed without fixing this kind error." - in ppError (isError @lhs.options @me) (getPos @rule) mesg pat help act @lhs.verbose - - | IncompatibleAttachKind - lhs.pp = let mesg = "child" >#< @child >#< "cannot be called from a visit with kind " >#< show @kind - pat = empty - help = empty - act = text "It is not possible to proceed without fixing this kind error." - in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose - -{ -toWidth :: Int -> String -> String -toWidth n xs | k PP_Doc -showEdge ((inh,syn),_,_) - = text ("inherited attribute " ++ toWidth 20 (getName inh) ++ " with synthesized attribute " ++ getName syn) - -showEdgeLong :: ((Identifier,Identifier),[String],[String]) -> PP_Doc -showEdgeLong ((inh,syn),path1,path2) - = text ("inherited attribute " ++ getName inh ++ " is needed for " ++ "synthesized attribute " ++ getName syn) - >-< indent 4 (vlist (map text path2)) - >-< text "and back: " - >-< indent 4 (vlist (map text path1)) - -attrText :: Identifier -> Identifier -> String -attrText inh syn - = if inh == syn - then "threaded attribute " ++ getName inh - else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn - -showLineNr :: Int -> String -showLineNr i | i==(-1) = "CR" - | otherwise = show i - -showAttrDef :: Identifier -> Identifier -> String -showAttrDef f a | f == _LHS = "synthesized attribute " ++ getName a - | f == _LOC = "local attribute " ++ getName a - | f == _INST = "inst attribute " ++ getName a - | otherwise = "inherited attribute " ++ getName a ++ " of field " ++ getName f - -showAttrUse :: Identifier -> Identifier -> String -showAttrUse f a | f == _LHS = "inherited attribute " ++ getName a - | f == _LOC = "local attribute " ++ getName a - | f == _INST = "inst attribute " ++ getName a - | otherwise = "synthesized attribute " ++ getName a ++ " of field " ++ getName f - -ppAttr :: Identifier -> Identifier -> PP_Doc -ppAttr f a = text (getName f++"."++getName a) -ppAttrUse :: Identifier -> Identifier -> PP_Doc -ppAttrUse f a = "@" >|< ppAttr f a -} --- Printing of error messages - -{ -infixr 5 +#+ -(+#+) :: String -> String -> String -(+#+) s t = s ++ " " ++ t - -infixr 5 +.+ -(+.+) :: Identifier -> Identifier -> String -(+.+) s t = getName s ++ "." ++ getName t - -wfill :: [String] -> PP_Doc -wfill = fill . addSpaces. concat . map words - where addSpaces (x:xs) = x:map addSpace xs - addSpaces [] = [] - addSpace [x] | x `elem` ".,;:!?" = [x] - addSpace xs = ' ':xs - -ppError :: Bool -- class of the error, True:error False:warning - -> Pos -- source position - -> PP_Doc -- error message - -> PP_Doc -- pattern - -> PP_Doc -- help, more info - -> PP_Doc -- action taken by AG - -> Bool -- verbose? show help and action? - -> PP_Doc -ppError isErr pos mesg pat hlp act verb - = let position = case pos of - Pos l c f | l >= 0 -> f >|< ":" >|< show l >|< ":" >|< show c - | otherwise -> pp "uuagc" - tp = if isErr then "error" else "warning" - header = position >|< ":" >#< tp >|< ":" >#< mesg - pattern = "pattern :" >#< pat - help = "help :" >#< hlp - action = "action :" >#< act - in if verb - then vlist [text "",header,pattern,help,action] - else header - -{- --- old error reporting code - = let - cl = if isError then "ERROR" else "Warning" - position = case pos of - (Pos l c f) | l >= 0 -> f >|< ": line " >|< show l >|< ", column " >|< show c - | otherwise -> empty - header = "*** UU.AG" >#< cl >#< position >#< "***" - message = "problem :" >#< mesg - pattern = "pattern :" >#< pat - help = "help :" >#< hlp - action = "action :" >#< act - in - if verbose - then vlist [text "",header,message,pattern,help,action] - else vlist [text "",header,message] --} - -showPos :: Identifier -> String -showPos = show . getPos - -ppInterface :: Show a => a -> PP_Doc -ppInterface inter = wfill ["interface:", show inter] - -} - +INCLUDE "ErrorMessages.ag" + +imports +{ +import UU.Scanner.Position(Pos(..), noPos) +import ErrorMessages +import Data.List(mapAccumL) +import GrammarInfo +import qualified Control.Monad.Error.Class as Err +} + + +{ +instance Err.Error Error where + noMsg = Err.strMsg "error" + strMsg = CustomError False noPos . pp +} + + +{ +isError :: Options -> Error -> Bool +isError _ (ParserError _ _ _ ) = True +isError _ (DupAlt _ _ _ ) = False +isError _ (DupSynonym _ _ ) = False +isError _ (DupSet _ _ ) = False +isError _ (DupInhAttr _ _ _ ) = True +isError _ (DupSynAttr _ _ _ ) = True +isError _ (DupChild _ _ _ _ ) = False +isError _ (DupRule _ _ _ _ _) = True +isError _ (DupSig _ _ _ ) = False +isError _ (UndefNont _ ) = True +isError _ (UndefAlt _ _ ) = True +isError _ (UndefChild _ _ _ ) = True +isError _ (MissingRule _ _ _ _ ) = False +isError _ (SuperfluousRule _ _ _ _ ) = False +isError _ (UndefLocal _ _ _ ) = True +isError _ (ChildAsLocal _ _ _ ) = False +isError _ (UndefAttr _ _ _ _ _) = True +isError _ (CyclicSet _ ) = True +isError _ (CustomError w _ _ ) = not w +isError opts (LocalCirc _ _ _ _ _) = cycleIsDangerous opts +isError opts (InstCirc _ _ _ _ _) = cycleIsDangerous opts +isError opts (DirectCirc _ _ _ ) = cycleIsDangerous opts +isError opts (InducedCirc _ _ _ ) = cycleIsDangerous opts +isError _ (MissingTypeSig _ _ _ ) = False +isError _ (MissingInstSig _ _ _ ) = True +isError _ (DupUnique _ _ _ ) = False +isError _ (MissingUnique _ _ ) = True +isError _ (MissingSyn _ _ ) = True +isError _ (MissingNamedRule _ _ _) = True +isError _ (DupRuleName _ _ _) = True +isError _ (HsParseError _ _) = True +isError _ (Cyclic _ _ _) = True +isError _ (IncompatibleVisitKind _ _ _ _) = True +isError _ (IncompatibleRuleKind _ _) = True +isError _ (IncompatibleAttachKind _ _) = True + +cycleIsDangerous :: Options -> Bool +cycleIsDangerous opts + = any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ] +} + + + + + + +ATTR Error [ options:{Options} verbose:{Bool} | | pp :{PP_Doc} + me :SELF + ] + +ATTR Errors [ options:{Options} dups : {[String]} | | pp USE {>-<} {text ""} : {PP_Doc} + ] + +SEM Errors + | * loc.verbose = verbose @lhs.options + | Cons loc.str = disp @hd.pp 5000 "" + + lhs.pp = if @loc.str `elem` @lhs.dups + then @tl.pp + else @hd.pp >-< @tl.pp + tl.dups = @loc.str : @lhs.dups + | Nil lhs.pp = text "" + + +SEM Error + | ParserError lhs.pp = let mesg = text ("parser expecting " ++ @problem) + pat = text "" + help = text "" + act = text @action + in ppError (isError @lhs.options @me) @pos mesg pat help act @lhs.verbose + + | HsParseError lhs.pp = ppError True @pos (text @msg) (text "") (text "") (text "Correct the syntax of the Haskell code.") @lhs.verbose + + | DupAlt lhs.pp = let mesg = wfill ["Repeated definition for alternative", getName @con + ,"of nonterminal", getName @nt, "." + ] >-< + wfill ["First definition:", (showPos @occ1),"."] >-< + wfill ["Other definition:", (showPos @con),"."] + pat = "DATA" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< "...") + >-< indent 2 ("|" >#< getName @con >#< "...") + + help = wfill ["The nonterminal",getName @nt,"has more than one alternative that" + ,"is labelled with the constructor name",getName @con,"." + ,"You should either rename or remove enough of them to make all" + ,"constructors of",getName @nt,"uniquely named." + ] + + act = wfill [ "The first alternative of name",getName @con + ,"you have given for nonterminal",getName @nt + ,"is considered valid. All other alternatives have been discarded." + ] + + in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose + + | DupSynonym lhs.pp = let mesg = wfill ["Definition of type synonym", getName @nt, "clashes with another" + ,"type synonym." + ] >-< + wfill ["First definition:", (showPos @occ1),"."] >-< + wfill ["Type synonym :" , (showPos @nt),"."] + pat = "DATA" >#< getName @nt + >-< indent 2 ("|" >#< "...") + >-< "TYPE" >#< getName @nt >#< "=" >#< "..." + help = wfill ["A type synonym with name", getName @nt + ,"has been given while there already is TYPE" + ,"definition with the same name." + ,"You should either rename or remove the type synonym." + ] + act = wfill [ "The clashing type synonym will be ignored." + ] + in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose + + | DupSet lhs.pp = let mesg = wfill ["Definition of nonterminal set", getName @name, "clashes with another" + ,"set, a type synonym or a data definition." + ] >-< + wfill ["First definition:", (showPos @occ1),"."] >-< + wfill ["Set definition:" , (showPos @name),"."] + pat = "SET" >#< getName @name >#< "=" >#< "..." + >-< "SET" >#< getName @name >#< "=" >#< "..." + help = wfill ["A nonterminal set with name", getName @name + ,"has been given while there already is a SET, DATA, or TYPE" + ,"definition with the same name." + ,"You should either rename or remove the nonterminal set." + ] + act = wfill [ "The clashing nonterminal set will be ignored." + ] + in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose + + | DupInhAttr lhs.pp = let mesg = wfill ["Repeated declaration of inherited attribute", getName @attr + , "of nonterminal", getName @nt, "." + ] >-< + wfill ["First definition:", (showPos @occ1),"."] >-< + wfill ["Other definition:", (showPos @attr),"."] + pat = "ATTR" >#< getName @nt >#< "[" >#< getName @attr >|< ":...," + >#< getName @attr >|< ":... | | ]" + + help = wfill ["The identifier" , getName @attr ,"has been declared" + ,"as an inherited (or chained) attribute for nonterminal" + ,getName @nt , "more than once, with possibly different types." + ,"Delete all but one or rename them to make them unique." + ] + act = wfill ["One declaration with its corresponding type is considered valid." + ,"All others have been discarded. The generated program will probably not run." + ] + + in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose + + | DupSynAttr lhs.pp = let mesg = wfill ["Repeated declaration of synthesized attribute", getName @attr + , "of nonterminal", getName @nt, "." + ] >-< + wfill ["First definition:", (showPos @occ1),"."] >-< + wfill ["Other definition:", (showPos @attr),"."] + pat = "ATTR" >#< getName @nt >#< "[ | |" >#< getName @attr >|< ":...," + >#< getName @attr >|< ":... ]" + + help = wfill ["The identifier" , getName @attr ,"has been declared" + ,"as a synthesized (or chained) attribute for nonterminal" + ,getName @nt , "more than once, with possibly different types." + ,"Delete all but one or rename them to make them unique." + ] + act = wfill ["One declaration with its corresponding type is considered valid." + ,"All others have been discarded. The generated program will probably not run." + ] + + in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose + + | DupChild lhs.pp = let mesg = wfill ["Repeated declaration for field", getName @name, "of alternative" + ,getName @con, "of nonterminal", getName @nt, "." + ] >-< + wfill ["First definition:", (showPos @occ1),"."] >-< + wfill ["Other definition:", (showPos @name),"."] + pat = "DATA" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< (getName @name >|< ":..." >-< getName @name >|< ":...")) + + + help = wfill ["The alternative" ,getName @con , "of nonterminal" ,getName @nt + ,"has more than one field that is named" + , getName @name ++ ". Possibly they have different types." + ,"You should either rename or remove enough of them to make all fields of" + ,getName @con , "for nonterminal " , getName @nt , "uniquely named." + ] + act = wfill ["The last declaration with its corresponding type is considered valid." + ,"All others have been discarded." + ] + in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose + + | DupRule lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rules for" + ,showAttrDef @field @attr,"." + ] >-< + wfill ["First rule:", (showPos @occ1),"."] >-< + wfill ["Other rule:", (showPos @attr),"."] + + pat = "SEM" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") + >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") + + help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt + ,", there is more than one rule for the" , showAttrDef @field @attr + ,". You should either rename or remove enough of them to make all rules for alternative" + ,getName @con , "of nonterminal " ,getName @nt , "uniquely named." + ] + act = wfill ["The last rule given is considered valid. All others have been discarded."] + in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose + + | DupRuleName lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more rule names for" + ,show @nm,"." + ] + + pat = "SEM" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...") + >-< indent 2 ("|" >#< getName @con >#< show @nm >#< ": ... = ...") + + help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt + ,", there is more than one rule name " , show @nm + ,". You should either rename or remove enough of them." + ] + act = wfill ["Compilation cannot continue."] + in ppError (isError @lhs.options @me) (getPos @nm) mesg pat help act @lhs.verbose + + | DupSig lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more typesignatures for" + ,showAttrDef _LOC @attr,"." + ] >-< + wfill ["First signature:", (showPos @attr),"."] + + pat = "SEM" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...") + >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< "= ...") + + help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt + ,", there is more than one rule for the" , showAttrDef _LOC @attr + ,". You should remove enough of them to make all typesignatures for alternative" + ,getName @con , "of nonterminal " ,getName @nt , "unique." + ] + act = wfill ["The last typesignature given is considered valid. All others have been discarded."] + in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose + + | UndefNont lhs.pp = let mesg = wfill ["Nonterminal", getName @nt, "is not defined." + ] + pat = "DATA" >#< getName @nt >#< "..." + + help = wfill ["There are attributes and/or rules for nonterminal" , getName @nt ,", but there is no definition" + , "for" ,getName @nt, ". Maybe you misspelled it? Otherwise insert a definition." + ] + act = wfill ["Everything regarding the unknown nonterminal has been ignored."] + in ppError (isError @lhs.options @me) (getPos @nt) mesg pat help act @lhs.verbose + + | UndefAlt lhs.pp = let mesg = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt, "is not defined." + ] + pat = "DATA" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< "...") + + help = wfill ["There are rules for alternative", getName @con , "of nonterminal" ,getName @nt + ,", but there is no definition for this alternative in the definitions of the" + ,"nonterminal" , getName @nt, ". Maybe you misspelled it? Otherwise insert a definition." + ] + act = wfill ["All rules for the unknown alternative have been ignored."] + in ppError (isError @lhs.options @me) (getPos @con) mesg pat help act @lhs.verbose + + | UndefChild lhs.pp = let mesg = wfill ["Constructor", getName @con, "of nonterminal" ,getName @nt + , "does not have a nontrivial field named", getName @name , "." + ] + pat = "SEM" >#< @nt + >-< indent 2 ("|" >#< getName @con >#< ppAttr @name (identifier "") >#< "= ...") + + help = wfill ["There are rules that define or use attributes of field" , getName @name + ,"in alternative" , getName @con , "of nonterminal" , getName @nt + ,", but there is no field with AG-type in the definition of the alternative." + ,"Maybe you misspelled it? Otherwise insert the field into the definition," + ,"or change its type from an HS-type to an AG-type." + ] + act = wfill ["All rules for the unknown field have been ignored."] + in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose + + | MissingRule lhs.pp = let mesg = wfill ["Missing rule for", showAttrDef @field @attr , "in alternative" + , getName @con , "of nonterminal",getName @nt ,"." + ] + pat = "SEM" >#< @nt + >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") + + help = wfill ["The", showAttrDef @field @attr, "in alternative", getName @con + , "of nonterminal", getName @nt, "is missing and cannot be inferred" + ,"by a copy rule, so you should add an appropriate rule." + ] + act = wfill ["The value of the attribute has been set to undefined."] + in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose + + | MissingNamedRule lhs.pp = let mesg = wfill ["Missing rule name ", show @name , "in alternative" + , getName @con , "of nonterminal",getName @nt ,"." + ] + pat = "SEM" >#< @nt + >-< indent 2 ("|" >#< getName @con >#< show @name >#< ": ... = ...") + + help = wfill ["There is a dependency on a rule with name ", show @name , "in alternative" + , getName @con , "of nonterminal",getName @nt ,", but no rule has been defined with this name. Maybe you misspelled it?" + ] + act = wfill ["Compilation cannot continue."] + in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose + + | SuperfluousRule lhs.pp = let mesg = wfill ["Rule for non-existing", showAttrDef @field @attr , "at alternative" + , getName @con , "of nonterminal",getName @nt, "." + ] + pat = "SEM" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< ppAttr @field @attr >#< "= ...") + + + help = wfill ["There is a rule for" , showAttrDef @field @attr , "in the definitions for alternative" , getName @con + ,"of nonterminal" , getName @nt, ", but this attribute does not exist. Maybe you misspelled it?" + ,"Otherwise either remove the rule or add an appropriate attribute definition." + ] + act = wfill ["The rule has been ignored."] + in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose + + | UndefLocal lhs.pp = let mesg = wfill ["Undefined local variable or field",getName @var, "at constructor" + , getName @con , "of nonterminal",getName @nt, "." + ] + pat = "SEM" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< ". = " + >#< "..." >#< "@" >|< getName @var >#< "..." ) + + help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal" + , getName @nt , "contains a local variable or field name that is not defined. " + ,"Maybe you misspelled it?" + ,"Otherwise either remove the rule or add an appropriate definition." + ] + act = wfill ["The generated program will not run."] + in ppError (isError @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose + + | ChildAsLocal lhs.pp = let mesg = wfill ["Nontrivial field ",getName @var, "is used as local at constructor" + , getName @con , "of nonterminal",getName @nt, "." + ] + pat = "SEM" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< "... = " + >#< "..." >#< "@" >|< getName @var >#< "..." ) + + help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal" + , getName @nt , "contains a nontrivial field name", getName @var, "." + ,"You should use @", getName @var, ".self instead, where self is a SELF-attribute." + ] + act = wfill ["The generated program probably contains a type error or has undefined variables."] + in ppError (isError @lhs.options @me) (getPos @var) mesg pat help act @lhs.verbose + + | UndefAttr lhs.pp = let mesg = wfill ["Undefined" + , if @isOut + then showAttrDef @field @attr + else showAttrUse @field @attr + , "at constructor" + , getName @con , "of nonterminal",getName @nt, "." + ] + pat = "SEM" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< ". = " + >#< "..." >#< ppAttrUse @field @attr >#< "...") + + help = wfill ["A rule in the definitions for alternative" , getName @con ,"of nonterminal" + ,getName @nt , "contains an attribute that is not defined" + ,"Maybe you misspelled it?" + ,"Otherwise either remove the rule or add an appropriate attribute definition." + ] + act = wfill ["The generated program will not run."] + in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose + + | CyclicSet lhs.pp = let mesg = wfill ["Cyclic definition for nonterminal set", getName @name] + pat = "SET" >#< getName @name >#< "=" >#< "..." >#< getName @name >#< "..." + help = wfill ["The defintion for a nonterminal set named" , getName @name + ,"directly or indirectly refers to itself." + ,"Adapt the definition of the nonterminal set, to remove the cyclic dependency." + ] + act = wfill ["The nonterminal set", getName @name, "is considered to be empty."] + in ppError (isError @lhs.options @me) (getPos @name) mesg pat help act @lhs.verbose + + | Cyclic lhs.pp = let pos = getPos @nt + mesg = text "Circular dependency for nonterminal" >#< getName @nt + >#< ( case @mbCon of + Nothing -> empty + Just con -> text "and constructor" >#< con + ) + >#< ( case @verts of + v : _ -> text "including vertex" >#< text v + _ -> empty + ) + pat = text "cyclic rule definition" + help = hlist (text "The following attributes are all cyclic: " : map text @verts) + act = wfill ["code cannot be generated until the cycle is removed."] + in ppError (isError @lhs.options @me) pos mesg pat help act False + + | CustomError lhs.pp = let pat = text "unknown" + help = wfill ["not available."] + act = wfill ["unknown"] + in ppError (isError @lhs.options @me) @pos @mesg pat help act False + + | LocalCirc lhs.pp = let mesg = wfill ["Circular dependency for local attribute", getName @attr + , "of alternative", getName @con, "of nonterminal", getName @nt] + pat = "SEM" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< "loc." >|< getName @attr >#< "=" + >#< "..." >#< "@loc." >|< getName @attr >#< "...") + help = if null @path + then text "the definition is directly circular" + else hlist ("The following attributes are involved in the cycle:": @path) + act | @o_visit = text "An unoptimized version was generated. It might hang when run." + | otherwise = text "The generated program might hang when run." + in ppError (isError @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose + + | InstCirc lhs.pp = let mesg = wfill ["Circular dependency for inst attribute", getName @attr + , "of alternative", getName @con, "of nonterminal", getName @nt] + pat = "SEM" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< "inst." >|< getName @attr >#< "=" + >#< "..." >#< "@s." >#< "...") + help = if null @path + then text "the definition is directly circular" + else hlist ("The following attributes are involved in the cycle:": @path) + act | @o_visit = text "An unoptimized version was generated. It might hang when run." + | otherwise = text "The generated program might hang when run." + in ppError (isError @lhs.options @me) (getPos (@attr)) mesg pat help act @lhs.verbose + + | DirectCirc lhs.pp = let mesg = wfill ["In nonterminal", getName @nt, "synthesized and inherited attributes are mutually dependent" ] + >-< vlist (map showEdge @cyclic) + pat = text "" + help = vlist (map showEdgeLong @cyclic) + act | @o_visit = text "An unoptimized version was generated. It might hang when run." + | otherwise = text "The generated program might hang when run." + in ppError (isError @lhs.options @me) noPos mesg pat help act @lhs.verbose + + | InducedCirc lhs.pp = let mesg = wfill ["After scheduling, in nonterminal", getName @nt, "synthesized and inherited attributes have an INDUCED mutual dependency" ] + >-< vlist (map showEdge @cyclic) + pat = text "" + showInter (CInterface segs) = concat (snd (mapAccumL (\i c -> (succ i :: Integer,("visit " ++ show i) : map ind (showsSegment c))) 0 segs)) + help = vlist (("Interface for nonterminal " ++ getName @nt ++ ":") : map ind (showInter @cinter)) + >-< vlist (map showEdgeLong @cyclic) + act = text "An unoptimized version was generated. It might hang when run." + in ppError (isError @lhs.options @me) noPos mesg pat help act @lhs.verbose + + | MissingTypeSig lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _LOC @attr , "in alternative" + , getName @con , "of nonterminal",getName @nt ,"." + ]>-< + wfill ["Location:", (showPos @attr),"."] + pat = "SEM" >#< @nt + >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< ": ...") + help = wfill ["The", showAttrDef _LOC @attr, "in alternative", getName @con + ,"of nonterminal", getName @nt, "is needed in two separate visits to", getName @nt + ,"so its type is needed to generate type signatures." + ,"Please supply its type." + ] + act = wfill ["The type signatures of semantic functions are not generated."] + in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose + + | MissingInstSig lhs.pp = let mesg = wfill ["Type signature needed, but not found for", showAttrDef _INST @attr , "in alternative" + , getName @con , "of nonterminal",getName @nt ,"." + ]>-< + wfill ["Location:", (showPos @attr),"."] + pat = "SEM" >#< @nt + >-< indent 2 ("|" >#< getName @con >#< ppAttr _INST @attr >#< ": ...") + help = wfill ["The", showAttrDef _INST @attr, "in alternative", getName @con + ,"of nonterminal", getName @nt, "is a non-terminal attribute, so " + ,"its type is needed to attribute its value." + ,"Please supply its type." + ] + act = wfill ["It is not possible to proceed without this signature."] + in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose + + | MissingUnique lhs.pp = let mesg = wfill ["Missing unique counter (chained attribute)" + , getName @attr + , "at nonterminal" + , getName @nt, "." + ] + pat = "ATTR" >#< getName @nt >#< "[ |" >#< getName @attr >#< " : ... | ]" + + help = wfill ["A unique attribute signature in a constructor for nonterminal" , getName @nt + , "refers to an unique counter (chained attribute) named " + , getName @attr + ,"Maybe you misspelled it?" + ,"Otherwise either remove the signature or add an appropriate attribute definition." + ] + act = wfill ["It is not possible to proceed without this declaration."] + in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose + + | DupUnique lhs.pp = let mesg = wfill ["At constructor",getName @con, "of nonterminal", getName @nt, "there are two or more unique-attribute signatures for" + ,showAttrDef _LOC @attr,"." + ] >-< + wfill ["First signature:", (showPos @attr),"."] + + pat = "SEM" >#< getName @nt + >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...") + >-< indent 2 ("|" >#< getName @con >#< ppAttr _LOC @attr >#< " : UNIQUEREF ...") + + help = wfill ["In the rules for alternative" , getName @con , "of nonterminal" , getName @nt + ,", there is more than one unique-attribute signature for the" , showAttrDef _LOC @attr + ,". You should remove enough of them to make all unique-signatures for alternative" + ,getName @con , "of nonterminal " ,getName @nt , "unique." + ] + act = wfill ["Unpredicatable sharing of unique numbers may occur."] + in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose + + | MissingSyn lhs.pp = let mesg = wfill ["Missing synthesized attribute" + , getName @attr + , "at nonterminal" + , getName @nt, "." + ] + pat = "ATTR" >#< getName @nt >#< "[ | | " >#< getName @attr >#< " : ... ]" + + help = wfill ["An augment rule for a constructor for nonterminal" , getName @nt + , "refers to a synthesized attribute named " + , getName @attr + ,"Maybe you misspelled it?" + ,"Otherwise add an appropriate attribute definition." + ] + act = wfill ["It is not possible to proceed without this declaration."] + in ppError (isError @lhs.options @me) (getPos @attr) mesg pat help act @lhs.verbose + | IncompatibleVisitKind + lhs.pp = let mesg = "visit" >#< @vis >#< "of child" >#< @child >#< " with kind" >#< show @to >#< " cannot be called from a visit with kind " >#< show @from + pat = empty + help = empty + act = text "It is not possible to proceed without fixing this kind error." + in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose + | IncompatibleRuleKind + lhs.pp = let mesg = "rule" >#< @rule >#< "cannot be called from a visit with kind " >#< show @kind + pat = empty + help = empty + act = text "It is not possible to proceed without fixing this kind error." + in ppError (isError @lhs.options @me) (getPos @rule) mesg pat help act @lhs.verbose + + | IncompatibleAttachKind + lhs.pp = let mesg = "child" >#< @child >#< "cannot be called from a visit with kind " >#< show @kind + pat = empty + help = empty + act = text "It is not possible to proceed without fixing this kind error." + in ppError (isError @lhs.options @me) (getPos @child) mesg pat help act @lhs.verbose + +{ +toWidth :: Int -> String -> String +toWidth n xs | k PP_Doc +showEdge ((inh,syn),_,_) + = text ("inherited attribute " ++ toWidth 20 (getName inh) ++ " with synthesized attribute " ++ getName syn) + +showEdgeLong :: ((Identifier,Identifier),[String],[String]) -> PP_Doc +showEdgeLong ((inh,syn),path1,path2) + = text ("inherited attribute " ++ getName inh ++ " is needed for " ++ "synthesized attribute " ++ getName syn) + >-< indent 4 (vlist (map text path2)) + >-< text "and back: " + >-< indent 4 (vlist (map text path1)) + +attrText :: Identifier -> Identifier -> String +attrText inh syn + = if inh == syn + then "threaded attribute " ++ getName inh + else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn + +showLineNr :: Int -> String +showLineNr i | i==(-1) = "CR" + | otherwise = show i + +showAttrDef :: Identifier -> Identifier -> String +showAttrDef f a | f == _LHS = "synthesized attribute " ++ getName a + | f == _LOC = "local attribute " ++ getName a + | f == _INST = "inst attribute " ++ getName a + | otherwise = "inherited attribute " ++ getName a ++ " of field " ++ getName f + +showAttrUse :: Identifier -> Identifier -> String +showAttrUse f a | f == _LHS = "inherited attribute " ++ getName a + | f == _LOC = "local attribute " ++ getName a + | f == _INST = "inst attribute " ++ getName a + | otherwise = "synthesized attribute " ++ getName a ++ " of field " ++ getName f + +ppAttr :: Identifier -> Identifier -> PP_Doc +ppAttr f a = text (getName f++"."++getName a) +ppAttrUse :: Identifier -> Identifier -> PP_Doc +ppAttrUse f a = "@" >|< ppAttr f a +} +-- Printing of error messages + +{ +infixr 5 +#+ +(+#+) :: String -> String -> String +(+#+) s t = s ++ " " ++ t + +infixr 5 +.+ +(+.+) :: Identifier -> Identifier -> String +(+.+) s t = getName s ++ "." ++ getName t + +wfill :: [String] -> PP_Doc +wfill = fill . addSpaces. concat . map words + where addSpaces (x:xs) = x:map addSpace xs + addSpaces [] = [] + addSpace [x] | x `elem` ".,;:!?" = [x] + addSpace xs = ' ':xs + +ppError :: Bool -- class of the error, True:error False:warning + -> Pos -- source position + -> PP_Doc -- error message + -> PP_Doc -- pattern + -> PP_Doc -- help, more info + -> PP_Doc -- action taken by AG + -> Bool -- verbose? show help and action? + -> PP_Doc +ppError isErr pos mesg pat hlp act verb + = let position = case pos of + Pos l c f | l >= 0 -> f >|< ":" >|< show l >|< ":" >|< show c + | otherwise -> pp "uuagc" + tp = if isErr then "error" else "warning" + header = position >|< ":" >#< tp >|< ":" >#< mesg + pattern = "pattern :" >#< pat + help = "help :" >#< hlp + action = "action :" >#< act + in if verb + then vlist [text "",header,pattern,help,action] + else header + +{- +-- old error reporting code + = let + cl = if isError then "ERROR" else "Warning" + position = case pos of + (Pos l c f) | l >= 0 -> f >|< ": line " >|< show l >|< ", column " >|< show c + | otherwise -> empty + header = "*** UU.AG" >#< cl >#< position >#< "***" + message = "problem :" >#< mesg + pattern = "pattern :" >#< pat + help = "help :" >#< hlp + action = "action :" >#< act + in + if verbose + then vlist [text "",header,message,pattern,help,action] + else vlist [text "",header,message] +-} + +showPos :: Identifier -> String +showPos = show . getPos + +ppInterface :: Show a => a -> PP_Doc +ppInterface inter = wfill ["interface:", show inter] + +} + diff --git a/src-ag/PrintOcamlCode.ag b/src-ag/PrintOcamlCode.ag --- a/src-ag/PrintOcamlCode.ag +++ b/src-ag/PrintOcamlCode.ag @@ -1,222 +1,222 @@ -PRAGMA strictdata -PRAGMA optimize -PRAGMA bangpats -PRAGMA strictwrap - -INCLUDE "Code.ag" -INCLUDE "Patterns.ag" - -imports -{ -import Pretty -import Code -import Patterns -import Options -import CommonTypes hiding (List,Type,Map,Maybe,IntMap,Either) -import Data.List(intersperse,intercalate) -import Data.Char(toLower) -} - - -{ -type PP_Docs = [PP_Doc] - -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs - -ppTuple :: Bool -> [PP_Doc] -> PP_Doc -ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps -ppTuple False pps = "(" >|< pp_block " " ")" "," pps -} - - --- --- Pass options down --- - -ATTR Program Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ] - -ATTR Program Chunks Chunk [ textBlockMap : {Map BlockInfo PP_Doc} | | ] - - --- --- Collect outputs --- - -ATTR Program [ | | output:{PP_Docs} ] -ATTR Expr Decl DataAlt CaseAlt Type NamedType Lhs Pattern [ | | pp:{PP_Doc} ] -ATTR Exprs DataAlts CaseAlts Types NamedTypes Decls Chunk Chunks Patterns [ | | pps : {PP_Docs} ] - -SEM Program - | Program lhs.output = @chunks.pps - -SEM Exprs - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM CaseAlts - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM DataAlts - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Types - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM NamedTypes - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Decls - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - -SEM Chunks - | Cons lhs.pps = @hd.pps ++ @tl.pps - | Nil lhs.pps = [] - -SEM Patterns - | Cons lhs.pps = @hd.pp : @tl.pps - | Nil lhs.pps = [] - --- --- Individual cases --- - -SEM Chunk - | Chunk lhs.pps = @comment.pp - : @info.pps - ++ @dataDef.pps - ++ @semDom.pps - ++ @semFunctions.pps - ++ @semWrapper.pps - ++ @cataFun.pps - ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap] - -SEM Decl - | Decl lhs.pp = if @lhs.isToplevel - then "let" >#< @left.pp >#< "=" - >-< indent 4 @rhs.pp >#< ";;" - else "let" >#< @left.pp >#< "=" - >-< indent 4 @rhs.pp >#< "in" - | Bind lhs.pp = error "pp of Decl.Bind not supported" - | BindLet lhs.pp = error "pp of Decl.BindLet not supported" - | Data lhs.pp = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name]) - >#< ( case @alts.pps of - [] -> empty - (x:xs) -> "=" >#< x - >-< vlist (map ("|" >#<) xs) - ) - >#< ";;" - | NewType lhs.pp = error "pp of Decl.NewType not supported" - | Type lhs.pp = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name]) >#< "=" >#< @tp.pp >#< ";;" - | TSig lhs.pp = "(*" >#< @name >#< ":" >#< @tp.pp >#< "*)" - | Comment lhs.pp = if '\n' `elem` @txt - then "(* " >-< vlist (lines @txt) >-< "*)" - else "(*" >#< @txt >#< "*)" - | PragmaDecl lhs.pp = error "pp of Decl.PragmaDecl not supported" - - - SEM Expr - | Let lhs.pp = pp_parens $ vlist (@decls.pps ++ [@body.pp]) - | Case lhs.pp = pp_parens ( "match" >#< @expr.pp >#< "with" - >-< indent 2 ( case @alts.pps of - [] -> empty - (x:xs) -> " " >#< x - >-< vlist (map ("|" >#<) xs) - ) - ) - | Do lhs.pp = error "pp of Expr.Do not supported" - | Lambda lhs.pp = pp_parens ( pp "fun" >#< hv_sp @args.pps >#< "->" - >-< indent 2 @body.pp ) - | TupleExpr lhs.pp = ppTuple False @exprs.pps - | UnboxedTupleExpr lhs.pp = error "pp of Expr.UnboxedTupleExpr not supported" - | App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps - | SimpleExpr lhs.pp = text @txt - | TextExpr lhs.pp = vlist (map text @lns) - | Trace lhs.pp = @expr.pp - | PragmaExpr lhs.pp = @expr.pp - | LineExpr lhs.pp = @expr.pp - | TypedExpr lhs.pp = @expr.pp - -SEM Lhs - | Pattern3 lhs.pp = @pat3.pp - | Pattern3SM lhs.pp = error "pp of Lhs.Pattern3SM not supported" - | TupleLhs lhs.pp = ppTuple False (map text @comps) - | UnboxedTupleLhs lhs.pp = error "pp of Lhs.UnboxedTupleLhs not supported" - | Fun lhs.pp = @name >#< hv_sp @args.pps - | Unwrap lhs.pp = pp_parens (@name >#< @sub.pp) - -SEM Type - | Arr lhs.pp = pp_parens (@left.pp >#< "->" >#< @right.pp) - | CtxApp lhs.pp = error "pp of Type.CtxApp not supported" - | TypeApp lhs.pp = pp_parens (hv_sp (@args.pps ++ [@func.pp])) - | TupleType lhs.pp = pp_block "(" ")" "," @tps.pps - | UnboxedTupleType - lhs.pp = error "pp of Type.UnboxedTupleType is not supported" - | List lhs.pp = @tp.pp >#< "list" - | SimpleType lhs.pp = text @txt - | NontermType lhs.pp = pp_block "(" ")" " " (map text @params ++ [text $ toOcamlTC @name]) - | TMaybe lhs.pp = @tp.pp >#< "opt" - | TEither lhs.pp = error "pp of Type.TEither is not supported" - | TMap lhs.pp = error "pp of Type.TMap is not supported" - | TIntMap lhs.pp = error "pp of Type.TIntMap is not supported" - | TSet lhs.pp = error "pp of Type.TSet is not supported" - | TIntSet lhs.pp = error "pp of Type.TIntSet is not supported" - -{ -toOcamlTC :: String -> String -toOcamlTC (c:cs) = toLower c : cs -toOcamlTC xs = xs -} - -SEM CaseAlt - | CaseAlt lhs.pp = @left.pp >#< "->" >#< @expr.pp - -SEM DataAlt - | DataAlt lhs.pp = @name >#< "of" >#< pp_block "" "" " * " (map pp_parens @args.pps) - | Record lhs.pp = pp_block "{" "}" ";" @args.pps - -SEM NamedType - | Named lhs.pp = @name >#< ":" >#< @tp.pp - -SEM Pattern - | Constr lhs.pp = pp_parens $ @name >#< hv_sp @pats.pps - | Product lhs.pp = pp_block "(" ")" "," @pats.pps - | Alias -- assuming here that there is only an underscore under an alias - lhs.pp = if @pat.isUnderscore - then pp (attrname @lhs.options False @field @attr) - else error "pp of Pattern.Alias is only supported in the form (x@_)" - | Irrefutable lhs.pp = error "pp of Pattern.Irrefutable not supported" - | Underscore lhs.pp = text "_" - -SEM Pattern [ | | isUnderscore:{Bool}] - | Constr lhs.isUnderscore = False - | Product lhs.isUnderscore = False - | Alias lhs.isUnderscore = False - | Underscore lhs.isUnderscore = True - --- --- Determine if a declaration is toplevel --- - -ATTR Chunks Chunk Decls Decl [ isToplevel : Bool | | ] -SEM Program - | Program - chunks.isToplevel = True - -SEM Expr - | Let - decls.isToplevel = False - | Do - stmts.isToplevel = False +PRAGMA strictdata +PRAGMA optimize +PRAGMA bangpats +PRAGMA strictwrap + +INCLUDE "Code.ag" +INCLUDE "Patterns.ag" + +imports +{ +import Pretty +import Code +import Patterns +import Options +import CommonTypes hiding (List,Type,Map,Maybe,IntMap,Either) +import Data.List(intersperse,intercalate) +import Data.Char(toLower) +} + + +{ +type PP_Docs = [PP_Doc] + +ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqH = ppMultiSeq' (>#<) + +ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqV = ppMultiSeq' (>-<) + +ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeq' next strictArgs expr + = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs + +ppTuple :: Bool -> [PP_Doc] -> PP_Doc +ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps +ppTuple False pps = "(" >|< pp_block " " ")" "," pps +} + + +-- +-- Pass options down +-- + +ATTR Program Expr Exprs Decl Decls Chunk Chunks CaseAlts CaseAlt Lhs Pattern Patterns [ options:{Options} | | ] + +ATTR Program Chunks Chunk [ textBlockMap : {Map BlockInfo PP_Doc} | | ] + + +-- +-- Collect outputs +-- + +ATTR Program [ | | output:{PP_Docs} ] +ATTR Expr Decl DataAlt CaseAlt Type NamedType Lhs Pattern [ | | pp:{PP_Doc} ] +ATTR Exprs DataAlts CaseAlts Types NamedTypes Decls Chunk Chunks Patterns [ | | pps : {PP_Docs} ] + +SEM Program + | Program lhs.output = @chunks.pps + +SEM Exprs + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM CaseAlts + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM DataAlts + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM Types + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM NamedTypes + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM Decls + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM Chunks + | Cons lhs.pps = @hd.pps ++ @tl.pps + | Nil lhs.pps = [] + +SEM Patterns + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +-- +-- Individual cases +-- + +SEM Chunk + | Chunk lhs.pps = @comment.pp + : @info.pps + ++ @dataDef.pps + ++ @semDom.pps + ++ @semFunctions.pps + ++ @semWrapper.pps + ++ @cataFun.pps + ++ [Map.findWithDefault empty (BlockOther, Just $ identifier @name) @lhs.textBlockMap] + +SEM Decl + | Decl lhs.pp = if @lhs.isToplevel + then "let" >#< @left.pp >#< "=" + >-< indent 4 @rhs.pp >#< ";;" + else "let" >#< @left.pp >#< "=" + >-< indent 4 @rhs.pp >#< "in" + | Bind lhs.pp = error "pp of Decl.Bind not supported" + | BindLet lhs.pp = error "pp of Decl.BindLet not supported" + | Data lhs.pp = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name]) + >#< ( case @alts.pps of + [] -> empty + (x:xs) -> "=" >#< x + >-< vlist (map ("|" >#<) xs) + ) + >#< ";;" + | NewType lhs.pp = error "pp of Decl.NewType not supported" + | Type lhs.pp = "type" >#< hv_sp (map (\p -> "'" >|< p) @params ++ [text $ toOcamlTC @name]) >#< "=" >#< @tp.pp >#< ";;" + | TSig lhs.pp = "(*" >#< @name >#< ":" >#< @tp.pp >#< "*)" + | Comment lhs.pp = if '\n' `elem` @txt + then "(* " >-< vlist (lines @txt) >-< "*)" + else "(*" >#< @txt >#< "*)" + | PragmaDecl lhs.pp = error "pp of Decl.PragmaDecl not supported" + + + SEM Expr + | Let lhs.pp = pp_parens $ vlist (@decls.pps ++ [@body.pp]) + | Case lhs.pp = pp_parens ( "match" >#< @expr.pp >#< "with" + >-< indent 2 ( case @alts.pps of + [] -> empty + (x:xs) -> " " >#< x + >-< vlist (map ("|" >#<) xs) + ) + ) + | Do lhs.pp = error "pp of Expr.Do not supported" + | Lambda lhs.pp = pp_parens ( pp "fun" >#< hv_sp @args.pps >#< "->" + >-< indent 2 @body.pp ) + | TupleExpr lhs.pp = ppTuple False @exprs.pps + | UnboxedTupleExpr lhs.pp = error "pp of Expr.UnboxedTupleExpr not supported" + | App lhs.pp = pp_parens $ @name >#< hv_sp @args.pps + | SimpleExpr lhs.pp = text @txt + | TextExpr lhs.pp = vlist (map text @lns) + | Trace lhs.pp = @expr.pp + | PragmaExpr lhs.pp = @expr.pp + | LineExpr lhs.pp = @expr.pp + | TypedExpr lhs.pp = @expr.pp + +SEM Lhs + | Pattern3 lhs.pp = @pat3.pp + | Pattern3SM lhs.pp = error "pp of Lhs.Pattern3SM not supported" + | TupleLhs lhs.pp = ppTuple False (map text @comps) + | UnboxedTupleLhs lhs.pp = error "pp of Lhs.UnboxedTupleLhs not supported" + | Fun lhs.pp = @name >#< hv_sp @args.pps + | Unwrap lhs.pp = pp_parens (@name >#< @sub.pp) + +SEM Type + | Arr lhs.pp = pp_parens (@left.pp >#< "->" >#< @right.pp) + | CtxApp lhs.pp = error "pp of Type.CtxApp not supported" + | TypeApp lhs.pp = pp_parens (hv_sp (@args.pps ++ [@func.pp])) + | TupleType lhs.pp = pp_block "(" ")" "," @tps.pps + | UnboxedTupleType + lhs.pp = error "pp of Type.UnboxedTupleType is not supported" + | List lhs.pp = @tp.pp >#< "list" + | SimpleType lhs.pp = text @txt + | NontermType lhs.pp = pp_block "(" ")" " " (map text @params ++ [text $ toOcamlTC @name]) + | TMaybe lhs.pp = @tp.pp >#< "opt" + | TEither lhs.pp = error "pp of Type.TEither is not supported" + | TMap lhs.pp = error "pp of Type.TMap is not supported" + | TIntMap lhs.pp = error "pp of Type.TIntMap is not supported" + | TSet lhs.pp = error "pp of Type.TSet is not supported" + | TIntSet lhs.pp = error "pp of Type.TIntSet is not supported" + +{ +toOcamlTC :: String -> String +toOcamlTC (c:cs) = toLower c : cs +toOcamlTC xs = xs +} + +SEM CaseAlt + | CaseAlt lhs.pp = @left.pp >#< "->" >#< @expr.pp + +SEM DataAlt + | DataAlt lhs.pp = @name >#< "of" >#< pp_block "" "" " * " (map pp_parens @args.pps) + | Record lhs.pp = pp_block "{" "}" ";" @args.pps + +SEM NamedType + | Named lhs.pp = @name >#< ":" >#< @tp.pp + +SEM Pattern + | Constr lhs.pp = pp_parens $ @name >#< hv_sp @pats.pps + | Product lhs.pp = pp_block "(" ")" "," @pats.pps + | Alias -- assuming here that there is only an underscore under an alias + lhs.pp = if @pat.isUnderscore + then pp (attrname @lhs.options False @field @attr) + else error "pp of Pattern.Alias is only supported in the form (x@_)" + | Irrefutable lhs.pp = error "pp of Pattern.Irrefutable not supported" + | Underscore lhs.pp = text "_" + +SEM Pattern [ | | isUnderscore:{Bool}] + | Constr lhs.isUnderscore = False + | Product lhs.isUnderscore = False + | Alias lhs.isUnderscore = False + | Underscore lhs.isUnderscore = True + +-- +-- Determine if a declaration is toplevel +-- + +ATTR Chunks Chunk Decls Decl [ isToplevel : Bool | | ] +SEM Program + | Program + chunks.isToplevel = True + +SEM Expr + | Let + decls.isToplevel = False + | Do + stmts.isToplevel = False diff --git a/src-ag/PrintVisitCode.ag b/src-ag/PrintVisitCode.ag --- a/src-ag/PrintVisitCode.ag +++ b/src-ag/PrintVisitCode.ag @@ -1,53 +1,53 @@ -PRAGMA strictwrap -PRAGMA strictdata -PRAGMA optimize - -INCLUDE "CodeSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "DeclBlocks.ag" - -imports -{ -import CommonTypes -import SequentialTypes -import Options -import CodeSyntax -import ErrorMessages -import GrammarInfo -import DeclBlocks -import Pretty - -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq) -import UU.Scanner.Position - -import Data.List(partition,intersperse,intersect,(\\)) -import Data.Maybe(fromJust,isJust) -} - -{ -type PP_Docs = [PP_Doc] - -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs -} - - -WRAPPER CGrammar - -ATTR CGrammar [ options:{Options} | | output:{PP_Docs} ] - -SEM CGrammar - | CGrammar - lhs.output = [] +PRAGMA strictwrap +PRAGMA strictdata +PRAGMA optimize + +INCLUDE "CodeSyntax.ag" +INCLUDE "Patterns.ag" +INCLUDE "DeclBlocks.ag" + +imports +{ +import CommonTypes +import SequentialTypes +import Options +import CodeSyntax +import ErrorMessages +import GrammarInfo +import DeclBlocks +import Pretty + +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Set as Set +import Data.Set(Set) +import qualified Data.Sequence as Seq +import Data.Sequence(Seq) +import UU.Scanner.Position + +import Data.List(partition,intersperse,intersect,(\\)) +import Data.Maybe(fromJust,isJust) +} + +{ +type PP_Docs = [PP_Doc] + +ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqH = ppMultiSeq' (>#<) + +ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqV = ppMultiSeq' (>-<) + +ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeq' next strictArgs expr + = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs +} + + +WRAPPER CGrammar + +ATTR CGrammar [ options:{Options} | | output:{PP_Docs} ] + +SEM CGrammar + | CGrammar + lhs.output = [] diff --git a/src-ag/ResolveLocals.ag b/src-ag/ResolveLocals.ag --- a/src-ag/ResolveLocals.ag +++ b/src-ag/ResolveLocals.ag @@ -1,157 +1,157 @@ -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "DistChildAttr.ag" - - --- --- Checks right-hand sides for missing attributes. --- Attribute references @xxx are now explicitly mapped to @loc.xxx if there is such --- an attribute in scope and there is no terminal @xxx. --- - - -imports -{ -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq,(><)) -import CommonTypes -import Patterns -import ErrorMessages -import AbstractSyntax -import Expression -import Options -import HsToken(HsTokensRoot(HsTokensRoot)) -import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) -import Data.Maybe -} - -WRAPPER Grammar - - --- --- Main attributes --- - -ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Expression - [ options:{Options} | | ] - -ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression - [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] - -ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression - [ | | output : SELF ] - --- --- Collect inputs to expressions --- - --- Collecting nts -ATTR Nonterminal Nonterminals - Production Productions - Rule Rules - Child Children [allnts:{[Identifier]} | | ] - -SEM Grammar - | Grammar nonts.allnts = map fst (@nonts.nonts) - -ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ] -SEM Nonterminal - | Nonterminal lhs.nonts = [(@nt,@prods.cons)] -ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ] -SEM Production - | Production lhs.cons = [@con] - --- Collecting fields -ATTR Rule Rules - Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ] - -SEM Production - | Production loc.allfields = @children.fields - .attrs = map ((,) _LOC) @rules.locVars ++ - map ((,) _INST) @rules.instVars ++ - map ((,) _LHS) @inhnames ++ - concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes] - .inhnames = Map.keys @lhs.inh - .synnames = Map.keys @lhs.syn - -ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ] -SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ] - | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)] - -SEM Child [ | | field : {(Identifier,Type,ChildKind)} ] - | Child lhs.field = (@name, @tp, @kind) - -SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ] - | Cons lhs.fields = @hd.field : @tl.fields - | Nil lhs.fields = [] - -ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ] - -SEM Pattern - | Alias lhs.locVars = if @field == _LOC - then [@attr] - else [] - lhs.instVars = if @field == _INST - then [@attr] - else [] - --- Distributing name of nonterminal and names of attributes -ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ] -ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ] - -SEM Production - | Production children . con = @con -SEM Production - | Production rules . con = @con -SEM Nonterminal - | Nonterminal prods . nt = @nt - -SEM Nonterminal - | Nonterminal prods.inh = @inh - prods.syn = @syn - --- merge map -SEM Grammar - | Grammar nonts.mergeMap = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap - -ATTR Nonterminals Nonterminal - [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ] - -ATTR Productions Production - [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))} | | ] - -SEM Nonterminal | Nonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap -SEM Production | Production loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap - -ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ] - - --- --- Handling Expressions --- - -ATTR Expression [ nt,con :{Identifier} - allfields:{[(Identifier,Type,ChildKind)]} - allnts :{[Identifier]} - attrs :{[(Identifier,Identifier)]} - || ] - -SEM Expression - | Expression loc.(errors,newTks) - = let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ] - attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs - inherited = Inh_HsTokensRoot - { attrs_Inh_HsTokensRoot = attrsIn - , con_Inh_HsTokensRoot = @lhs.con - , allfields_Inh_HsTokensRoot = @lhs.allfields - , allnts_Inh_HsTokensRoot = @lhs.allnts - , nt_Inh_HsTokensRoot = @lhs.nt - , options_Inh_HsTokensRoot = @lhs.options - } - synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited - in (errors_Syn_HsTokensRoot synthesized, output_Syn_HsTokensRoot synthesized) - lhs.output = Expression @pos @loc.newTks +INCLUDE "AbstractSyntax.ag" +INCLUDE "Patterns.ag" +INCLUDE "Expression.ag" +INCLUDE "DistChildAttr.ag" + + +-- +-- Checks right-hand sides for missing attributes. +-- Attribute references @xxx are now explicitly mapped to @loc.xxx if there is such +-- an attribute in scope and there is no terminal @xxx. +-- + + +imports +{ +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Sequence as Seq +import Data.Sequence(Seq,(><)) +import CommonTypes +import Patterns +import ErrorMessages +import AbstractSyntax +import Expression +import Options +import HsToken(HsTokensRoot(HsTokensRoot)) +import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) +import Data.Maybe +} + +WRAPPER Grammar + + +-- +-- Main attributes +-- + +ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Expression + [ options:{Options} | | ] + +ATTR Grammar Nonterminals Nonterminal Productions Production Rule Rules Pattern Patterns Expression + [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ] + +ATTR Grammar Nonterminals Nonterminal Productions Production Child Children Rule Rules Pattern Patterns TypeSig TypeSigs Expression + [ | | output : SELF ] + +-- +-- Collect inputs to expressions +-- + +-- Collecting nts +ATTR Nonterminal Nonterminals + Production Productions + Rule Rules + Child Children [allnts:{[Identifier]} | | ] + +SEM Grammar + | Grammar nonts.allnts = map fst (@nonts.nonts) + +ATTR Nonterminals Nonterminal [ | | nonts USE {++} {[]} : {[(NontermIdent,[ConstructorIdent])]} ] +SEM Nonterminal + | Nonterminal lhs.nonts = [(@nt,@prods.cons)] +ATTR Productions Production [ | | cons USE {++} {[]} : {[ConstructorIdent]} ] +SEM Production + | Production lhs.cons = [@con] + +-- Collecting fields +ATTR Rule Rules + Child Children [allfields:{[(Identifier,Type,ChildKind)]} attrs:{[(Identifier,Identifier)]} | | ] + +SEM Production + | Production loc.allfields = @children.fields + .attrs = map ((,) _LOC) @rules.locVars ++ + map ((,) _INST) @rules.instVars ++ + map ((,) _LHS) @inhnames ++ + concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- @children.attributes] + .inhnames = Map.keys @lhs.inh + .synnames = Map.keys @lhs.syn + +ATTR Children [ | | attributes USE {++} {[]} : {[(Identifier,Attributes,Attributes)]} ] +SEM Child [ | | attributes:{[(Identifier,Attributes,Attributes)]} ] + | Child lhs.attributes = [(@name, @loc.inh, @loc.syn)] + +SEM Child [ | | field : {(Identifier,Type,ChildKind)} ] + | Child lhs.field = (@name, @tp, @kind) + +SEM Children [ | | fields : {[(Identifier,Type,ChildKind)]} ] + | Cons lhs.fields = @hd.field : @tl.fields + | Nil lhs.fields = [] + +ATTR Rules Rule Patterns Pattern [ | | locVars USE {++} {[]}:{[Identifier]} instVars USE {++} {[]} : {[Identifier]} ] + +SEM Pattern + | Alias lhs.locVars = if @field == _LOC + then [@attr] + else [] + lhs.instVars = if @field == _INST + then [@attr] + else [] + +-- Distributing name of nonterminal and names of attributes +ATTR Productions Production Child Children Rules Rule Patterns Pattern [ nt : {Identifier} inh,syn : {Attributes} | | ] +ATTR Child Children Rules Rule Patterns Pattern [ con : {Identifier} | | ] + +SEM Production + | Production children . con = @con +SEM Production + | Production rules . con = @con +SEM Nonterminal + | Nonterminal prods . nt = @nt + +SEM Nonterminal + | Nonterminal prods.inh = @inh + prods.syn = @syn + +-- merge map +SEM Grammar + | Grammar nonts.mergeMap = Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) @mergeMap + +ATTR Nonterminals Nonterminal + [ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))} | | ] + +ATTR Productions Production + [ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))} | | ] + +SEM Nonterminal | Nonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap +SEM Production | Production loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap + +ATTR Rules Rule Children Child Expression [ mergeMap : {Map Identifier (Identifier,[Identifier])} | | ] + + +-- +-- Handling Expressions +-- + +ATTR Expression [ nt,con :{Identifier} + allfields:{[(Identifier,Type,ChildKind)]} + allnts :{[Identifier]} + attrs :{[(Identifier,Identifier)]} + || ] + +SEM Expression + | Expression loc.(errors,newTks) + = let mergedChildren = [ x | (_,xs) <- Map.elems @lhs.mergeMap, x <- xs ] + attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) @lhs.attrs + inherited = Inh_HsTokensRoot + { attrs_Inh_HsTokensRoot = attrsIn + , con_Inh_HsTokensRoot = @lhs.con + , allfields_Inh_HsTokensRoot = @lhs.allfields + , allnts_Inh_HsTokensRoot = @lhs.allnts + , nt_Inh_HsTokensRoot = @lhs.nt + , options_Inh_HsTokensRoot = @lhs.options + } + synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot @tks)) inherited + in (errors_Syn_HsTokensRoot synthesized, output_Syn_HsTokensRoot synthesized) + lhs.output = Expression @pos @loc.newTks diff --git a/src-ag/SemHsTokens.ag b/src-ag/SemHsTokens.ag --- a/src-ag/SemHsTokens.ag +++ b/src-ag/SemHsTokens.ag @@ -1,144 +1,144 @@ -INCLUDE "HsToken.ag" - -imports -{ -import qualified Data.Sequence as Seq -import Data.Sequence(Seq,empty,singleton,(><)) -import Data.Foldable(toList) -import Pretty - -import TokenDef -import HsToken -import ErrorMessages -} - -ATTR HsTokensRoot - [ - | | - errors USE {Seq.><} {Seq.empty}:{Seq Error} - usedLocals:{[Identifier]} - usedAttrs :{[(Identifier,Identifier)]} - textLines :{[String]} - usedFields:{[Identifier]} - ] - -------------------------------------------------------------------------------- --- Context information -------------------------------------------------------------------------------- -ATTR HsTokensRoot - HsTokens HsToken [ nt,con : {Identifier} - allfields : {[(Identifier,Type,ChildKind)]} - allnts : {[Identifier]} - attrs : {[(Identifier,Identifier)]} - options : {Options} - || - ] - -ATTR HsTokens HsToken [ fieldnames : {[Identifier]} | | ] -SEM HsTokensRoot - | HsTokensRoot tokens.fieldnames = map (\(n,_,_) -> n) @lhs.allfields - -------------------------------------------------------------------------------- --- Errors -------------------------------------------------------------------------------- -ATTR HsTokens HsToken [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ] - -------------------------------------------------------------------------------- --- Syntax errors -------------------------------------------------------------------------------- - -SEM HsToken - | Err lhs.errors = let m = text @mesg - in Seq.singleton (CustomError False @pos m) - -------------------------------------------------------------------------------- --- Undefined variables -------------------------------------------------------------------------------- - -{ -isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts -isNTname allnts _ = False -} - - --- An AGLocal is either a local variable or a terminal -SEM HsToken - | AGLocal loc.tkAsLocal = AGLocal @var @pos @rdesc -- refers to the terminal - loc.tkAsField = AGField _LOC @var @pos @rdesc -- refers to the (local) attribute - loc.(errors,output,tok,usedLocals) = - if @var `elem` @lhs.fieldnames -- check if @var occurs as a terminal - then if isNTname @lhs.allnts (lookup @var (map (\(n,t,_) -> (n,t)) @lhs.allfields)) - then (Seq.singleton(ChildAsLocal @lhs.nt @lhs.con @var), @loc.tkAsLocal,(@pos,fieldname @var), [] ) - else (Seq.empty, @loc.tkAsLocal, (@pos,fieldname @var), [] ) - else if (_LOC,@var) `elem` @lhs.attrs - then (Seq.empty , @loc.tkAsField, (@pos,locname @lhs.options @var), [@var]) - else (Seq.singleton(UndefLocal @lhs.nt @lhs.con @var), @loc.tkAsField, (@pos,locname @lhs.options @var), [] ) - -SEM HsToken - | AGField lhs.errors = if (@field,@attr) `elem` @lhs.attrs - then Seq.empty - else if not(@field `elem` (_LHS : _LOC: @lhs.fieldnames)) - then Seq.singleton (UndefChild @lhs.nt @lhs.con @field) - else Seq.singleton (UndefAttr @lhs.nt @lhs.con @field @attr False) - -------------------------------------------------------------------------------- --- Used variables -------------------------------------------------------------------------------- - -ATTR HsTokens HsToken [ | | usedLocals USE {++} {[]} : {[Identifier]} - usedAttrs USE {++} {[]} : {[(Identifier,Identifier)]} ] - -SEM HsToken - | AGField (lhs.usedAttrs,lhs.usedLocals) - = if @field == _LOC - then ([], [@attr]) - else ([(@field,@attr)], []) - - -------------------------------------------------------------------------------- --- Used fields -------------------------------------------------------------------------------- -ATTR HsTokens HsToken [ | | usedFields USE {Seq.><} {Seq.empty} : {Seq Identifier} ] - -SEM HsToken - | AGLocal lhs.usedFields = if @var `elem` @lhs.fieldnames - then Seq.singleton @var - else Seq.empty -SEM HsTokensRoot - | HsTokensRoot lhs.usedFields = toList @tokens.usedFields - -------------------------------------------------------------------------------- --- Pretty printing -------------------------------------------------------------------------------- - -SEM HsTokensRoot - | HsTokensRoot lhs.textLines = showTokens @tokens.tks - -SEM HsTokens [ || tks : {[(Pos,String)]} ] - | Cons lhs.tks = @hd.tok : @tl.tks - | Nil lhs.tks = [] - -SEM HsToken [ || tok:{(Pos,String)}] - | AGField - loc.addTrace = case @rdesc of - Just d -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))" - Nothing -> id - lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr) - - | HsToken lhs.tok = (@pos, @value) - - | CharToken lhs.tok = (@pos, if null @value - then "" - else showCharShort (head @value) - ) - - | StrToken lhs.tok = (@pos, showStrShort @value) - | Err lhs.tok = (@pos, "") - -------------------------------------------------------------------------------- --- Desugar (resolve AGLocals to explicit AGFields) -------------------------------------------------------------------------------- - -ATTR HsTokensRoot [ | | output : {[HsToken]} ] -ATTR HsTokens HsToken [ | | output : SELF ] - +INCLUDE "HsToken.ag" + +imports +{ +import qualified Data.Sequence as Seq +import Data.Sequence(Seq,empty,singleton,(><)) +import Data.Foldable(toList) +import Pretty + +import TokenDef +import HsToken +import ErrorMessages +} + +ATTR HsTokensRoot + [ + | | + errors USE {Seq.><} {Seq.empty}:{Seq Error} + usedLocals:{[Identifier]} + usedAttrs :{[(Identifier,Identifier)]} + textLines :{[String]} + usedFields:{[Identifier]} + ] + +------------------------------------------------------------------------------- +-- Context information +------------------------------------------------------------------------------- +ATTR HsTokensRoot + HsTokens HsToken [ nt,con : {Identifier} + allfields : {[(Identifier,Type,ChildKind)]} + allnts : {[Identifier]} + attrs : {[(Identifier,Identifier)]} + options : {Options} + || + ] + +ATTR HsTokens HsToken [ fieldnames : {[Identifier]} | | ] +SEM HsTokensRoot + | HsTokensRoot tokens.fieldnames = map (\(n,_,_) -> n) @lhs.allfields + +------------------------------------------------------------------------------- +-- Errors +------------------------------------------------------------------------------- +ATTR HsTokens HsToken [ | | errors USE {Seq.><} {Seq.empty}:{Seq Error} ] + +------------------------------------------------------------------------------- +-- Syntax errors +------------------------------------------------------------------------------- + +SEM HsToken + | Err lhs.errors = let m = text @mesg + in Seq.singleton (CustomError False @pos m) + +------------------------------------------------------------------------------- +-- Undefined variables +------------------------------------------------------------------------------- + +{ +isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts +isNTname allnts _ = False +} + + +-- An AGLocal is either a local variable or a terminal +SEM HsToken + | AGLocal loc.tkAsLocal = AGLocal @var @pos @rdesc -- refers to the terminal + loc.tkAsField = AGField _LOC @var @pos @rdesc -- refers to the (local) attribute + loc.(errors,output,tok,usedLocals) = + if @var `elem` @lhs.fieldnames -- check if @var occurs as a terminal + then if isNTname @lhs.allnts (lookup @var (map (\(n,t,_) -> (n,t)) @lhs.allfields)) + then (Seq.singleton(ChildAsLocal @lhs.nt @lhs.con @var), @loc.tkAsLocal,(@pos,fieldname @var), [] ) + else (Seq.empty, @loc.tkAsLocal, (@pos,fieldname @var), [] ) + else if (_LOC,@var) `elem` @lhs.attrs + then (Seq.empty , @loc.tkAsField, (@pos,locname @lhs.options @var), [@var]) + else (Seq.singleton(UndefLocal @lhs.nt @lhs.con @var), @loc.tkAsField, (@pos,locname @lhs.options @var), [] ) + +SEM HsToken + | AGField lhs.errors = if (@field,@attr) `elem` @lhs.attrs + then Seq.empty + else if not(@field `elem` (_LHS : _LOC: @lhs.fieldnames)) + then Seq.singleton (UndefChild @lhs.nt @lhs.con @field) + else Seq.singleton (UndefAttr @lhs.nt @lhs.con @field @attr False) + +------------------------------------------------------------------------------- +-- Used variables +------------------------------------------------------------------------------- + +ATTR HsTokens HsToken [ | | usedLocals USE {++} {[]} : {[Identifier]} + usedAttrs USE {++} {[]} : {[(Identifier,Identifier)]} ] + +SEM HsToken + | AGField (lhs.usedAttrs,lhs.usedLocals) + = if @field == _LOC + then ([], [@attr]) + else ([(@field,@attr)], []) + + +------------------------------------------------------------------------------- +-- Used fields +------------------------------------------------------------------------------- +ATTR HsTokens HsToken [ | | usedFields USE {Seq.><} {Seq.empty} : {Seq Identifier} ] + +SEM HsToken + | AGLocal lhs.usedFields = if @var `elem` @lhs.fieldnames + then Seq.singleton @var + else Seq.empty +SEM HsTokensRoot + | HsTokensRoot lhs.usedFields = toList @tokens.usedFields + +------------------------------------------------------------------------------- +-- Pretty printing +------------------------------------------------------------------------------- + +SEM HsTokensRoot + | HsTokensRoot lhs.textLines = showTokens @tokens.tks + +SEM HsTokens [ || tks : {[(Pos,String)]} ] + | Cons lhs.tks = @hd.tok : @tl.tks + | Nil lhs.tks = [] + +SEM HsToken [ || tok:{(Pos,String)}] + | AGField + loc.addTrace = case @rdesc of + Just d -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))" + Nothing -> id + lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr) + + | HsToken lhs.tok = (@pos, @value) + + | CharToken lhs.tok = (@pos, if null @value + then "" + else showCharShort (head @value) + ) + + | StrToken lhs.tok = (@pos, showStrShort @value) + | Err lhs.tok = (@pos, "") + +------------------------------------------------------------------------------- +-- Desugar (resolve AGLocals to explicit AGFields) +------------------------------------------------------------------------------- + +ATTR HsTokensRoot [ | | output : {[HsToken]} ] +ATTR HsTokens HsToken [ | | output : SELF ] + diff --git a/src-ag/TfmToMirage.ag b/src-ag/TfmToMirage.ag new file mode 100644 --- /dev/null +++ b/src-ag/TfmToMirage.ag @@ -0,0 +1,100 @@ +INCLUDE "AbstractSyntax.ag" +INCLUDE "Expression.ag" +INCLUDE "Order.ag" -- for dependencies + +imports { +import AbstractSyntax +import qualified Data.Map as Map +import Pretty +import TokenDef +import qualified MirageSyntax as Mirage +} + +{ +typeToMirage :: Type -> Mirage.Type +typeToMirage x = case x of + Haskell y -> Mirage.Haskell y + NT y ys _ -> Mirage.NT (getName y) ys + Self -> Mirage.Self +} + +SEM Grammar [ || mirage:{Mirage.Grammar} ] + | Grammar lhs.mirage = Mirage.Grammar @nonts.mirages + +SEM Nonterminals [ || mirages:{[Mirage.Nonterminal]} ] + | Cons lhs.mirages = @hd.mirage : @tl.mirages + | Nil lhs.mirages = [] + +SEM Nonterminal [ || mirage:{Mirage.Nonterminal} ] + | Nonterminal lhs.mirage + = Mirage.Nonterminal + (getName @nt) + (map getName @params) + (Map.foldrWithKey (\k x xs -> Mirage.Attribute (getName k) (typeToMirage x) : xs) [] @inh) + (Map.foldrWithKey (\k x xs -> Mirage.Attribute (getName k) (typeToMirage x) : xs) [] @syn) + @prods.mirages + +SEM Productions [ || mirages:{[Mirage.Production]} ] + | Cons lhs.mirages = @hd.mirage : @tl.mirages + | Nil lhs.mirages = [] + +SEM Production [ || mirage:{Mirage.Production} ] + | Production lhs.mirage + = Mirage.Production (getName @con) @children.mirages @rules.mirages + +SEM Children [ || mirages:{[Mirage.Child]} ] + | Cons lhs.mirages = @hd.mirage : @tl.mirages + | Nil lhs.mirages = [] + +SEM Child [ || mirage:{Mirage.Child} ] + | Child lhs.mirage = Mirage.Child (getName @name) (typeToMirage @tp) + +SEM Rules [ || mirages:{[Mirage.Rule]} ] + | Cons lhs.mirages = @hd.mirage : @tl.mirages + | Nil lhs.mirages = [] + +-- Partly from Order + +SEM Rule [ || mirage:{Mirage.Rule} ] + | Rule lhs.mirage + = Mirage.Rule + [Mirage.Address (getName field) (getName attr) | (field,attr,_) <- @pattern.patternAttrs] + ([Mirage.Address (getName field) (getName attr) | (field,attr) <- @rhs.usedAttrs] + ++ [ Mirage.Address (getName _LOC) (getName attr) | attr <- @rhs.usedLocals ++ @rhs.usedFields]) + @explicit + @origin + (disp (@pattern.pp >-< indent 1 (text "= " >|< vlist @rhs.lns)) 0 "") + +-- Partly from Visage + +SEM Expression [ | | lns : {[String]} ] + | Expression lhs.lns = showTokens . tokensToStrings $ @tks + +-- From PrintCode + +SEM Patterns [ | | pps : {[PP_Doc]} ] + | Cons lhs.pps = @hd.pp : @tl.pps + | Nil lhs.pps = [] + +SEM Pattern [ | | pp:PP_Doc ] + | Constr lhs.pp = pp_parens $ @name >#< hv_sp @pats.pps + | Product lhs.pp = pp_block "(" ")" "," @pats.pps + | Alias loc.ppVar = pp @field >|< "." >|< pp @attr + loc.ppVarBang = @loc.ppVar + lhs.pp = if @pat.isUnderscore + then @loc.ppVarBang + else @loc.ppVarBang >|< "@" >|< @pat.pp + | Irrefutable lhs.pp = text "~" >|< pp_parens @pat.pp + | Underscore lhs.pp = text "_" + +SEM Pattern [ | | isUnderscore:{Bool}] + | Constr lhs.isUnderscore = False + | Product lhs.isUnderscore = False + | Alias lhs.isUnderscore = False + | Underscore lhs.isUnderscore = True + +ATTR Pattern Patterns [ belowIrrefutable : Bool | | ] +SEM Rule + | Rule pattern.belowIrrefutable = False +SEM Pattern + | Irrefutable pat.belowIrrefutable = True diff --git a/src-ag/TfmToVisage.ag b/src-ag/TfmToVisage.ag --- a/src-ag/TfmToVisage.ag +++ b/src-ag/TfmToVisage.ag @@ -1,147 +1,147 @@ --- !!!! The Visage AST does not support nonterminals with type variables! --- !!!! Type variables in data type declarations are ignored. - -INCLUDE "AbstractSyntax.ag" -INCLUDE "Patterns.ag" -INCLUDE "Expression.ag" -INCLUDE "DistChildAttr.ag" - -imports { -import AbstractSyntax -import VisagePatterns -import VisageSyntax -import qualified Data.Map as Map -import Data.Map (Map) -} - -{ --- Maps a rule to a pair --- Later, I expect to map to a list of rules, because we might need to unfold. - - --- Checks that a certain alias is in fact a Var in the old representation of the AG system -isVar (Alias _ _ (Underscore _)) = True -isVar _ = False - -type VisageRuleMap = [(String, VisageRule)] - -splitVRules :: [VisageRule] -> VisageRuleMap -splitVRules vrs = concat (map unfoldvrs vrs) - -unfoldvrs :: VisageRule -> VisageRuleMap -unfoldvrs vr@(VRule attrfields _ _ _ _) = zip (map (getName . fst) attrfields) (map (copyRule vr) attrfields) - -copyRule :: VisageRule -> (Identifier,Identifier) -> VisageRule -copyRule (VRule attrfields _ pat expr owrt) (field,attr) = VRule attrfields attr pat expr owrt - -getForField :: String -> VisageRuleMap -> [VisageRule] -getForField field xs = map snd (filter ((field ==) . fst) xs) - -{- - Delivers a map from fieldname to VisageRule with all references to others underscored. - So, (lhs.x, rt.y, loc.z) = (0,1,2) becomes something like - [("lhs", (lhs.x,_,_) = (0,1,2) - - At this point, we do not use this anymore. - -allways :: VisageRule -> VisageRuleMap -allways vr@(VRule vrfields _ _ _ _) = zip vrfields (map (underScoreRule vr) (nub vrfields)) - -splitVRules :: [VisageRule] -> VisageRuleMap -splitVRules vrs = concat (map allways vrs) - -underScoreRule :: VisageRule -> String -> VisageRule -underScoreRule (VRule fields pat expr owrt rule) s = VRule fields (underScore s pat) expr owrt rule - -underScore :: String -> VisagePattern -> VisagePattern -underScore field (VConstr name pats) = VConstr name (map (underScore field) pats) -underScore field (VProduct pos pats) = VProduct pos (map (underScore field) pats) -underScore field vp@(VVar vfield attr) = - if (field == getName vfield) - then vp - else (VUnderscore (getPos vfield)) --- Should I recurse into the pat of VAlias? -underScore field vp@(VAlias afield attr pat) = - if (field == getName afield) - then vp - else (VUnderscore (getPos afield)) -underScore field vp@(VUnderscore pos) = vp - --} -} - - -ATTR Expression Pattern Patterns [ | | self : SELF ] - -ATTR Grammar [ || visage:{VisageGrammar} ] -ATTR Nonterminal [ || vnont:{VisageNonterminal} ] -ATTR Nonterminals [ || vnonts:{[VisageNonterminal]} ] -ATTR Production [ || vprod:{VisageProduction} ] -ATTR Productions [ || vprods:{[VisageProduction]} ] -ATTR Rule [ || vrule : {VisageRule} ] -ATTR Rules [ || vrules : {[VisageRule]} ] -ATTR Child [ rulemap : {VisageRuleMap} || vchild:{VisageChild} ] -ATTR Children [ rulemap : {VisageRuleMap} || vchildren:{[VisageChild]} ] -ATTR Pattern [ || vpat:{VisagePattern} ] -ATTR Patterns [ || vpats: {[VisagePattern]} ] - -SEM Grammar - | Grammar - lhs.visage = VGrammar @nonts.vnonts - -SEM Nonterminals - | Cons - lhs.vnonts = @hd.vnont : @tl.vnonts - | Nil - lhs.vnonts = [] - -SEM Nonterminal - | Nonterminal - lhs.vnont = VNonterminal @nt @inh @syn @prods.vprods - -SEM Productions - | Cons - lhs.vprods = @hd.vprod : @tl.vprods - | Nil - lhs.vprods = [] - -SEM Production - | Production - lhs.vprod = VProduction @con @children.vchildren @lhsrules @locrules - loc.splitVRules = splitVRules @rules.vrules - loc.locrules = getForField "loc" @splitVRules - loc.lhsrules = getForField "lhs" @splitVRules - children.rulemap = @splitVRules - -SEM Children - | Cons lhs.vchildren = @hd.vchild : @tl.vchildren - | Nil lhs.vchildren = [] - -SEM Child - | Child lhs.vchild = VChild @name @tp @loc.inh @loc.syn (getForField (getName @name) @lhs.rulemap) - -SEM Rules - | Cons lhs.vrules = @hd.vrule : @tl.vrules - | Nil lhs.vrules = [] - --- The undefined may seem strange, but it really belongs there. -SEM Rule - | Rule lhs.vrule = VRule @pattern.fieldattrs undefined @pattern.vpat @rhs.self @owrt - -SEM Patterns - | Cons lhs.vpats = @hd.vpat : @tl.vpats - | Nil lhs.vpats = [] - -SEM Pattern - | Constr lhs.vpat = VConstr @name @pats.vpats - | Product lhs.vpat = VProduct @pos @pats.vpats - | Alias lhs.vpat = if (isVar @self) - then VVar @field @attr - else VAlias @field @attr @pat.vpat - | Underscore lhs.vpat = VUnderscore @pos - --- All (field,attrs) in a pattern -ATTR Patterns -> Pattern [ | | fieldattrs USE { ++ } { [] } : { [(Identifier,Identifier)] } ] - -SEM Pattern - | Alias lhs.fieldattrs = [(@field, @attr)] +-- !!!! The Visage AST does not support nonterminals with type variables! +-- !!!! Type variables in data type declarations are ignored. + +INCLUDE "AbstractSyntax.ag" +INCLUDE "Patterns.ag" +INCLUDE "Expression.ag" +INCLUDE "DistChildAttr.ag" + +imports { +import AbstractSyntax +import VisagePatterns +import VisageSyntax +import qualified Data.Map as Map +import Data.Map (Map) +} + +{ +-- Maps a rule to a pair +-- Later, I expect to map to a list of rules, because we might need to unfold. + + +-- Checks that a certain alias is in fact a Var in the old representation of the AG system +isVar (Alias _ _ (Underscore _)) = True +isVar _ = False + +type VisageRuleMap = [(String, VisageRule)] + +splitVRules :: [VisageRule] -> VisageRuleMap +splitVRules vrs = concat (map unfoldvrs vrs) + +unfoldvrs :: VisageRule -> VisageRuleMap +unfoldvrs vr@(VRule attrfields _ _ _ _) = zip (map (getName . fst) attrfields) (map (copyRule vr) attrfields) + +copyRule :: VisageRule -> (Identifier,Identifier) -> VisageRule +copyRule (VRule attrfields _ pat expr owrt) (field,attr) = VRule attrfields attr pat expr owrt + +getForField :: String -> VisageRuleMap -> [VisageRule] +getForField field xs = map snd (filter ((field ==) . fst) xs) + +{- + Delivers a map from fieldname to VisageRule with all references to others underscored. + So, (lhs.x, rt.y, loc.z) = (0,1,2) becomes something like + [("lhs", (lhs.x,_,_) = (0,1,2) + + At this point, we do not use this anymore. + +allways :: VisageRule -> VisageRuleMap +allways vr@(VRule vrfields _ _ _ _) = zip vrfields (map (underScoreRule vr) (nub vrfields)) + +splitVRules :: [VisageRule] -> VisageRuleMap +splitVRules vrs = concat (map allways vrs) + +underScoreRule :: VisageRule -> String -> VisageRule +underScoreRule (VRule fields pat expr owrt rule) s = VRule fields (underScore s pat) expr owrt rule + +underScore :: String -> VisagePattern -> VisagePattern +underScore field (VConstr name pats) = VConstr name (map (underScore field) pats) +underScore field (VProduct pos pats) = VProduct pos (map (underScore field) pats) +underScore field vp@(VVar vfield attr) = + if (field == getName vfield) + then vp + else (VUnderscore (getPos vfield)) +-- Should I recurse into the pat of VAlias? +underScore field vp@(VAlias afield attr pat) = + if (field == getName afield) + then vp + else (VUnderscore (getPos afield)) +underScore field vp@(VUnderscore pos) = vp + +-} +} + + +ATTR Expression Pattern Patterns [ | | self : SELF ] + +ATTR Grammar [ || visage:{VisageGrammar} ] +ATTR Nonterminal [ || vnont:{VisageNonterminal} ] +ATTR Nonterminals [ || vnonts:{[VisageNonterminal]} ] +ATTR Production [ || vprod:{VisageProduction} ] +ATTR Productions [ || vprods:{[VisageProduction]} ] +ATTR Rule [ || vrule : {VisageRule} ] +ATTR Rules [ || vrules : {[VisageRule]} ] +ATTR Child [ rulemap : {VisageRuleMap} || vchild:{VisageChild} ] +ATTR Children [ rulemap : {VisageRuleMap} || vchildren:{[VisageChild]} ] +ATTR Pattern [ || vpat:{VisagePattern} ] +ATTR Patterns [ || vpats: {[VisagePattern]} ] + +SEM Grammar + | Grammar + lhs.visage = VGrammar @nonts.vnonts + +SEM Nonterminals + | Cons + lhs.vnonts = @hd.vnont : @tl.vnonts + | Nil + lhs.vnonts = [] + +SEM Nonterminal + | Nonterminal + lhs.vnont = VNonterminal @nt @inh @syn @prods.vprods + +SEM Productions + | Cons + lhs.vprods = @hd.vprod : @tl.vprods + | Nil + lhs.vprods = [] + +SEM Production + | Production + lhs.vprod = VProduction @con @children.vchildren @lhsrules @locrules + loc.splitVRules = splitVRules @rules.vrules + loc.locrules = getForField "loc" @splitVRules + loc.lhsrules = getForField "lhs" @splitVRules + children.rulemap = @splitVRules + +SEM Children + | Cons lhs.vchildren = @hd.vchild : @tl.vchildren + | Nil lhs.vchildren = [] + +SEM Child + | Child lhs.vchild = VChild @name @tp @loc.inh @loc.syn (getForField (getName @name) @lhs.rulemap) + +SEM Rules + | Cons lhs.vrules = @hd.vrule : @tl.vrules + | Nil lhs.vrules = [] + +-- The undefined may seem strange, but it really belongs there. +SEM Rule + | Rule lhs.vrule = VRule @pattern.fieldattrs undefined @pattern.vpat @rhs.self @owrt + +SEM Patterns + | Cons lhs.vpats = @hd.vpat : @tl.vpats + | Nil lhs.vpats = [] + +SEM Pattern + | Constr lhs.vpat = VConstr @name @pats.vpats + | Product lhs.vpat = VProduct @pos @pats.vpats + | Alias lhs.vpat = if (isVar @self) + then VVar @field @attr + else VAlias @field @attr @pat.vpat + | Underscore lhs.vpat = VUnderscore @pos + +-- All (field,attrs) in a pattern +ATTR Patterns -> Pattern [ | | fieldattrs USE { ++ } { [] } : { [(Identifier,Identifier)] } ] + +SEM Pattern + | Alias lhs.fieldattrs = [(@field, @attr)] diff --git a/src-ag/Transform.ag b/src-ag/Transform.ag --- a/src-ag/Transform.ag +++ b/src-ag/Transform.ag @@ -1,1371 +1,1371 @@ -PRAGMA strictdata -PRAGMA strictwrap - -INCLUDE "ConcreteSyntax.ag" -INCLUDE "Patterns.ag" - -imports -{ -import Control.Monad(mplus,mzero) -import Data.List (partition, nub,intersperse, union) -import Data.Maybe -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Set as Set (Set, member, union, toList, fromList, empty, singleton, member, unions, size, fold, intersection, difference, insert, elems) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq, (><)) -import UU.Scanner.Position(noPos) - -import ConcreteSyntax -import AbstractSyntax -import ErrorMessages -import Patterns (Patterns,Pattern(..)) -import Expression (Expression(..)) -import HsToken - -import RhsCheck -import Debug.Trace -} - - -------------------------------------------------------------------------------- --- Main goal -------------------------------------------------------------------------------- - --- Given some options, we want to construct a Grammar, that is, a structure that conforms to AbstractSyntax -ATTR AG [ | | output : Grammar ] -ATTR AG Elems Elem SemAlts SemAlt SemDefs SemDef Attrs [ options : Options | | ] - --- as a side effect, we generate error messages and Haskell code blocks that need to be embedded in the final code -ATTR AG Elems Elem SemAlts SemAlt Attrs NontSet ConstructorSet SemDefs SemDef - [ | | errors USE {Seq.><}{Seq.empty}:{Seq Error} ] -ATTR AG Elems Elem - [ | | blocks USE {`mapUnionWithPlusPlus`} {Map.empty}: {Blocks} ] - - --- The output is produced by calling a function that constructs the Grammar, --- given various datastructures that are collected from the concrete AG. - -SEM AG - | AG lhs.output = constructGrammar @loc.allNonterminals - @elems.paramsCollect - @loc.allConParams - @loc.allFields - @loc.prodOrder - @loc.allConstraints - @loc.allAttrDecls - @elems.useMap - @elems.derivings - (if wrappers @lhs.options then @loc.allNonterminals else @elems.wrappers) - @loc.checkedRules - @loc.checkedSigs - @loc.checkedInsts - @elems.typeSyns - @elems.semPragmasCollect - @elems.attrOrderCollect - @elems.ctxCollect - @elems.quantCollect - @loc.checkedUniques - @loc.checkedAugments - @loc.checkedArounds - @loc.checkedMerges - @loc.allMacros - - -------------------------------------------------------------------------------- --- Main data flow -------------------------------------------------------------------------------- - -{- Information is collected bottom-up (in multiple phases) - After checking for consistency, datastructures are createad from it, - which are passed down for the other phases. --} - - --- Names that are in use - - -- bottom-up collection -ATTR Elem Elems [ | | collectedSetNames USE {`Set.union`} {Set.empty} : {Set Identifier} ] -ATTR Elem Elems NontSet [ | | collectedNames USE {`Set.union`} {Set.empty} : {Set Identifier} ] - -- top-down distribution -ATTR Elem Elems Attrs Alts Alt Fields Field NontSet [ allNonterminals : {Set NontermIdent} | | ] - - --- Constructors that are in use - -- bottom-up collection -ATTR Alt Alts ConstructorSet [ | | collectedConstructorNames USE {`Set.union`} {Set.empty} : {Set ConstructorIdent} ] -ATTR Elem Elems [ | | collectedConstructorsMap USE {`mapUnionWithSetUnion`} {Map.empty} : {Map NontermIdent (Set ConstructorIdent)} ] - -- top-down distribution -ATTR Elem Elems Alts Alt [ allConstructors : {Map NontermIdent (Set ConstructorIdent)} | | ] - - - --- Nonterminal sets that are defined -{type DefinedSets = Map Identifier (Set NontermIdent) } - -- bottom-up collection -ATTR Elem Elems - [ | defSets:{Map Identifier (Set NontermIdent,Set Identifier)} | ] - -- top-down distribution -ATTR Elem Elems NontSet - [ definedSets:{DefinedSets} | | ] - - - --- Interpreting nonterminal sets -ATTR NontSet [ | | nontSet : {Set NontermIdent} ] - - --- Interpreting constructor sets -ATTR ConstructorSet [ | | constructors : {(Set ConstructorIdent->Set ConstructorIdent)} ] - - - --- Contextfree structure -{type FieldMap = [(Identifier, Type)] } -{type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) } - -- bottom-up collection -ATTR Alt Alts Elem Elems - [ | | collectedFields USE {++} {[]} : {[(NontermIdent, ConstructorIdent, FieldMap)]} - collectedConstraints USE {++} {[]} : {[(NontermIdent, ConstructorIdent, [Type])]} - collectedConParams USE {++} {[]} : {[(NontermIdent, ConstructorIdent, Set Identifier)]} - ] - -- top-down distribution -ATTR Elem Elems Attrs SemAlt SemAlts NontSet - [ allFields : {DataTypes} | | ] - - - --- Attribute declarations - -- bottom-up collection -ATTR Elems Elem Attrs - [ - | attrDecls:{Map NontermIdent (Attributes, Attributes)} - | useMap USE {`merge`} {Map.empty}:{Map NontermIdent (Map Identifier (String,String,String))} - ] - - --- Attribute definitions -{type AttrName = (Identifier,Identifier) } -{type RuleInfo = (Maybe Identifier, [AttrName]->Pattern, Expression, [AttrName], Bool, String, Bool, Bool) } -{type SigInfo = (Identifier,Type) } -{type UniqueInfo = (Identifier,Identifier) } -{type AugmentInfo = (Identifier,Expression)} -{type AroundInfo = (Identifier,Expression)} -{type MergeInfo = (Identifier, Identifier, [Identifier], Expression)} - -- bottom-up collection -ATTR Elem Elems SemAlt SemAlts - [ | | collectedRules USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, RuleInfo)]} - collectedSigs USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, SigInfo) ]} - collectedInsts USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [Identifier]) ]} - collectedUniques USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]} - collectedAugments USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]} - collectedArounds USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [AroundInfo]) ]} - collectedMerges USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [MergeInfo]) ]} - ] - - - -------------------------------------------------------------------------------- --- Passing nonterminals -------------------------------------------------------------------------------- - --- Pass the name of the associated nonterminal to everyone -ATTR Alt Alts SemAlt SemAlts [ nts:{Set NontermIdent} | | ] - -SEM Elem - | Data alts.nts = @names.nontSet - | Sem alts.nts = @names.nontSet - - - -------------------------------------------------------------------------------- --- Calculation of code blocks -- -------------------------------------------------------------------------------- - -SEM Elem - | Txt loc.blockInfo = ( @kind - , @mbNt - ) - loc.blockValue = [(@lines, @pos)] - lhs.blocks = Map.singleton @loc.blockInfo @loc.blockValue - lhs.errors = if checkParseBlock @lhs.options - then let ex = Expression @pos tks - tks = [tk] - tk = HsToken (unlines @lines) @pos - in Seq.fromList $ checkBlock $ ex - else Seq.empty - - -------------------------------------------------------------------------------- --- Check for duplicates and report error -------------------------------------------------------------------------------- - -{ - -checkDuplicate :: (Identifier -> Identifier -> Error) - -> Identifier -> val -> Map Identifier val -> (Map Identifier val,Seq Error) -checkDuplicate dupError key val m - = case Map.lookupIndex key m of - Just ix -> let (key',_) = Map.elemAt ix m - in (m,Seq.singleton (dupError key key')) - Nothing -> (Map.insert key val m,Seq.empty) - -checkDuplicates :: (Identifier -> Identifier -> Error) - -> [(Identifier, val)] -> Map Identifier val -> (Map Identifier val,Seq Error) -checkDuplicates dupError new m = foldErrors check m new - where check = uncurry (checkDuplicate dupError) - -foldErrors :: (b -> t -> (t, Seq Error)) -> t -> [b] -> (t, Seq Error) -foldErrors f n xs = foldl g (n,Seq.empty) xs - where g ~(e,es) x = let (e',es') = f x e - in (e', es >< es') - - -checkForDuplicates :: (Identifier -> Identifier -> Error) -> [Identifier] -> [Error] -checkForDuplicates _ [] = [] -checkForDuplicates err (x:xs) = let (same,other) = partition (equalId x) xs - in map (err x) same ++ checkForDuplicates err other - -equalId :: Identifier -> Identifier -> Bool -equalId x y = getName x == getName y - -} - -------------------------------------------------------------------------------- --- Collecting DATA's and type synonyms -------------------------------------------------------------------------------- - - -SEM Alt - | Alt lhs.collectedFields = [ (nt, con, @fields.collectedFields) - | nt <- Set.toList @lhs.nts - , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) - ] - lhs.collectedConstraints = [ (nt, con, @fields.collectedConstraints) - | nt <- Set.toList @lhs.nts - , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) - ] - lhs.collectedConParams = [ (nt, con, Set.fromList @tyvars) - | nt <- Set.toList @lhs.nts - , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) - ] - -SEM Elem - | Type lhs.collectedFields = map (\(x,y)->(@name, x, y)) @loc.expanded - -SEM AG - | AG - loc.prodOrder = let f (nt,con,_) = Map.insertWith g nt [con] - g [con] lst | con `elem` lst = lst - | otherwise = con : lst - g _ _ = error "This is not possible" - in foldr f Map.empty @elems.collectedFields - loc.allFields = let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm) - in foldr f (Map.empty) @elems.collectedFields - - loc.allConstraints = let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm) - in foldr f (Map.empty) @elems.collectedConstraints - - loc.allConParams = let f (nt,con,fm) = Map.insertWith (Map.unionWith Set.union) nt (Map.singleton con fm) - in foldr f (Map.empty) @elems.collectedConParams - - loc.allConstrs = let f (nt,con,_) = Map.insertWith (++) nt [con] - in foldr f (Map.empty) @elems.collectedFields - - loc.allRules = let f (nt,con,r) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [r]) - in foldr f (Map.empty) @elems.collectedRules - - loc.allSigs = let f (nt,con,t) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [t]) - typeof nt r = Map.findWithDefault (Haskell "") r $ fst $ Map.findWithDefault (Map.empty,Map.empty) nt @loc.allAttrDecls - in foldr f (Map.empty) ( @elems.collectedSigs - ++ [ (nt, con, (ident,typeof nt ref)) | (nt, con, us) <- @elems.collectedUniques, (ident,ref) <- us ] - ) - - loc.allInsts = let f (nt,con,is) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con is) - in foldr f (Map.empty) @elems.collectedInsts - - loc.allUniques = let f (nt,con,us) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con us) - in foldr f (Map.empty) @elems.collectedUniques - loc.allAugments = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as) - in foldr f Map.empty @elems.collectedAugments - loc.allArounds = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as) - in foldr f Map.empty @elems.collectedArounds - loc.allMerges = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as) - in foldr f Map.empty @elems.collectedMerges - - loc.augmentSigs = let gen _ = [] -- TODO: generate type signatures here for the augments - in Map.map (Map.map gen) @loc.allAugments - - loc.allRulesErrs = Map.mapWithKey (Map.mapWithKey . (checkRules @allAttrDecls @allFields @allInsts @loc.allSigs @loc.allMerges)) @loc.allRules - loc.allNamesErrs = Map.mapWithKey (Map.mapWithKey . checkRuleNames) @loc.allRules - loc.allSigsErrs = Map.mapWithKey (Map.mapWithKey . (checkSigs )) @loc.allSigs - loc.allInstsErrs = Map.mapWithKey (Map.mapWithKey . (checkInsts @loc.allNonterminals @loc.allSigs @allFields )) @loc.allInsts - loc.allUniquesErrs = Map.mapWithKey (Map.mapWithKey . (checkUniques @allAttrDecls )) @loc.allUniques - loc.allAugmentErrs = Map.mapWithKey (Map.mapWithKey . (checkAugments @allAttrDecls )) @loc.allAugments - loc.allAroundsErrs = Map.mapWithKey (Map.mapWithKey . (checkArounds @loc.allFields)) @loc.allArounds - loc.allMergesErrs = Map.mapWithKey (Map.mapWithKey . (checkMerges @loc.allNonterminals @loc.allInsts @loc.allFields)) @loc.allMerges - - loc.checkedRulesPre = Map.map (Map.map fst) @loc.allRulesErrs - loc.checkedSigs = Map.map (Map.map fst) @loc.allSigsErrs `unionunionplusplus` @loc.augmentSigs - loc.checkedInsts = Map.map (Map.map fst) @loc.allInstsErrs - loc.checkedUniques = Map.map (Map.map fst) @loc.allUniquesErrs - loc.checkedAugments = Map.map (Map.map fst) @loc.allAugmentErrs - loc.checkedArounds = Map.map (Map.map fst) @loc.allAroundsErrs - loc.checkedRules = Map.unionWith (Map.unionWith (++)) @loc.checkedRulesPre (Map.mapWithKey (Map.mapWithKey . (mkUniqueRules @lhs.options @loc.allRules @loc.allFields @loc.checkedInsts @loc.allAttrDecls)) @loc.checkedUniques) - loc.checkedMerges = Map.map (Map.map fst) @loc.allMergesErrs - - loc.errs1 = let f = checkForDuplicates (DupSynonym) - in Seq.fromList . f . map fst $ @elems.typeSyns -- forbid duplicate type synonyms - - loc.errs2 = let g nt (con,fm) = checkForDuplicates (DupChild nt con) (map fst fm) - f (nt,cfm) = concat . map (g nt) . Map.toList $ cfm - in Seq.fromList . concat . map f . Map.toList $ @allFields -- forbid duplicate fields - - loc.errs3 = let -- f (nt,cons) = checkForDuplicates (DupAlt nt) cons - in Seq.empty -- allow duplicate constructors, merging their fields - -- Seq.fromList . concat . map f . Map.toList $ @allConstrs -- forbid duplicate constructors - - loc.errs4 = let f m s = Map.foldr ((><) . snd) s m - in Map.foldr f Seq.empty @loc.allRulesErrs - - loc.errs5 = let f m s = Map.foldr ((><) . snd) s m - in Map.foldr f Seq.empty @loc.allSigsErrs - - loc.errs6 = let f m s = Map.foldr ((><) . snd) s m - in Map.foldr f Seq.empty @loc.allInstsErrs - - loc.errs7 = let f m s = Map.foldr ((><) . snd) s m - in Map.foldr f Seq.empty @loc.allUniquesErrs - - loc.errs8 = let f m s = Map.foldr ((><) . snd) s m - in Map.foldr f Seq.empty @loc.allAugmentErrs - - loc.errs9 = let f m s = Map.foldr ((><) . snd) s m - in Map.foldr f Seq.empty @loc.allAroundsErrs - - loc.errs10 = let f m s = Map.foldr ((><)) s m - in Map.foldr f Seq.empty @loc.allNamesErrs - - loc.errs11 = let f m s = Map.foldr ((><) . snd) s m - in Map.foldr f Seq.empty @loc.allMergesErrs - - lhs.errors = @elems.errors >< @errs1 >< @errs2 >< @errs3 >< @errs4 >< @errs5 >< @errs6 >< @errs7 >< @errs8 >< @errs9 >< @errs10 >< @errs11 - -{ -type RulesAndErrors = ([Rule], Seq Error) -type SigsAndErrors = ([TypeSig], Seq Error) -type InstsAndErrors = ([(Identifier, Type)], Seq Error) -type UniquesAndErrors = (Map Identifier Identifier, Seq Error) -type AugmentsAndErrors = (Map Identifier [Expression], Seq Error) -type AroundsAndErrors = (Map Identifier [Expression], Seq Error) -type MergesAndErrors = (Map Identifier (Identifier, [Identifier], Expression), Seq Error) -type AttrOverwrite = Map AttrName Bool -type AccumRuleCheck = (RulesAndErrors, AttrOverwrite) -type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName]) - -checkRules :: Map NontermIdent (Attributes, Attributes) -> DataTypes -> - Map NontermIdent (Map ConstructorIdent [Identifier]) -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> - Map NontermIdent (Map ConstructorIdent [MergeInfo]) -> - NontermIdent -> ConstructorIdent -> [RuleInfo] -> RulesAndErrors -checkRules attributes fields allinsts allsigs _ nt con rs - = let fieldmap :: FieldMap - fieldmap = (_LHS, NT nt [] False) : (_LOC, NT nullIdent [] False) : (_INST, NT nullIdent [] False) : (_FIRST, NT nullIdent [] False) : (_LAST, NT nullIdent [] False) - : Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fields) - ++ mapMaybe (\instNm -> lookup instNm sigs >>= \tp -> return (instNm, tp)) (Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allinsts)) - -- merged children are not allowed to have any inherited attrs defined: do not include - - sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allsigs) - - hasAttrib f tp attr = Map.member attr (f (Map.findWithDefault (Map.empty,Map.empty) tp attributes)) - - checkRule :: RuleInfo -> AccumRuleCheck -> AccumRuleCheck - checkRule (mbNm, pat,ex,as,owrt,str, pur, eager) ((r1,e1),m1) - = let (e2,m2,u2,_) = foldr (checkDefi owrt) (e1,m1,[],[]) as - in ( (Rule mbNm (pat u2) ex owrt str True pur False Nothing eager : r1, e2), m2) - - checkDefi :: Bool -> AttrName -> AccumDefiCheck -> AccumDefiCheck - checkDefi owrt fa@(field,attr) (e,m,u,bs) - = case lookup field fieldmap - of Just (NT tp _ _) -> - let tp' = maybe tp id (deforestedNt tp) - in if field == _LOC || field == _INST || field == _FIRST || field == _LAST - || hasAttrib (if getName field==getName _LHS then snd else fst) tp' attr - then case Map.lookupIndex fa m of - Just ix -> let ((_,attr2),b) = Map.elemAt ix m - in if b && not (fa `elem` bs) - then ( e, Map.insert fa owrt m, fa:u, fa:bs) - else (((Seq.<|)) (DupRule nt con field attr2 attr) e, m, fa:u, bs) - Nothing -> ( e, Map.insert fa owrt m, u, fa:bs) - else (((Seq.<|)) (SuperfluousRule nt con field attr) e, m, fa:u, bs) - _ -> (((Seq.<|)) (UndefChild nt con field) e, m, fa:u, bs ) - - in fst (foldr checkRule (([],Seq.empty),Map.empty) rs) - -checkRuleNames :: NontermIdent -> ConstructorIdent -> [RuleInfo] -> Seq Error -checkRuleNames nt con - = fst . foldr checkRule (Seq.empty, Set.empty) - where - checkRule (Just nm,_,_,_,_,_,_,_) (errs, nms) - | nm `Set.member` nms = (DupRuleName nt con nm Seq.<| errs, nms) - | otherwise = (errs, Set.insert nm nms) - checkRule (Nothing,_,_,_,_,_,_,_) inp = inp - -checkSigs :: NontermIdent -> ConstructorIdent -> [SigInfo] -> SigsAndErrors -checkSigs nt con sis - = let checkSig (ide,typ) (sigs,errs) - = if ide `elem` map (\(TypeSig n _)-> n) sigs - then (sigs, ((Seq.<|)) (DupSig nt con ide) errs) - -- else if not (ide `elem` locattrdefs) - -- then (sigs, ((Seq.<|)) (SupSig nt con ide) errs) - else (TypeSig ide typ:sigs, errs) - in foldr checkSig ([],Seq.empty) sis - -checkInsts :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [Identifier] -> InstsAndErrors -checkInsts allNts sigMap _ nt con - = foldr (\inst (insts, errs) -> - maybe (insts, Seq.singleton (MissingInstSig nt con inst) >< errs) - (\info@(k, NT nm args _) -> - case findInst k insts of - Just k' -> (insts, Seq.singleton (DupChild nt con k k') >< errs) - Nothing -> case nm `Set.member` allNts of - True -> (info : insts, errs) - False | take 2 (getName nm) == "T_" -> let nm' = Ident (drop 2 (getName nm)) (getPos nm) - info' = (k, NT nm' args True) -- this should be the only place at which 'for' with value True can be generated - in case nm' `Set.member` allNts of - True -> (info' : insts, errs) - False -> (insts, Seq.singleton (UndefNont nm') >< errs) - | otherwise -> (insts, Seq.singleton (UndefNont nm) >< errs) - ) - $ findSig inst - ) ([], Seq.empty) - where - sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt sigMap) - - findSig name - = do tp@(NT _ _ _) <- lookup name sigs - return (name, tp) - - findInst _ [] = Nothing - findInst k ((k', _): r) - | k == k' = Just k' - | otherwise = findInst k r - -checkUniques :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [UniqueInfo] -> UniquesAndErrors -checkUniques allAttrs nt con uniques - = let checkUnique (ident,ref) (us,errs) - = if ident `Map.member` us - then (us, ((Seq.<|)) (DupUnique nt con ident) errs) - else if Map.member ref inhs && Map.member ref syns - then (Map.insert ident ref us, errs) - else (us, ((Seq.<|)) (MissingUnique nt ref) errs) - - (inhs,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs - in foldr checkUnique (Map.empty, Seq.empty) uniques - -checkAugments :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [AugmentInfo] -> AugmentsAndErrors -checkAugments allAttrs nt _ augments - = let checkAugment (ident,expr) (as,errs) - = if ident `Map.member` as - then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs) - else if Map.member ident syns - then (Map.insert ident [expr] as, errs) - else (as, ((Seq.<|)) (MissingSyn nt ident) errs) - - (_,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs - in foldr checkAugment (Map.empty, Seq.empty) augments - -checkArounds :: DataTypes -> NontermIdent -> ConstructorIdent -> [AroundInfo] -> AroundsAndErrors -checkArounds fieldMap nt con arounds - = let checkAround (ident,expr) (as,errs) - = if ident `Map.member` as - then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs) - else case lookup ident fields of - Just (NT _ _ _) -> (Map.insert ident [expr] as, errs) - _ -> (as, ((Seq.<|)) (UndefChild nt con ident) errs) - fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap) - in foldr checkAround (Map.empty, Seq.empty) arounds - -checkMerges :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [Identifier]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [MergeInfo] -> MergesAndErrors -checkMerges allNts allInsts fieldMap _ con merges - = let checkMerge (target,nt,sources,expr) (m,errs) - = let fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap) - insts = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts) - allFields = insts ++ map fst fields -- note: sources of merge may not contain a target (for simplicity) - in if target `Map.member` m -- check for duplicate with self - then (m, DupChild nt con target (fst $ Map.elemAt (Map.findIndex target m) m) Seq.<| errs) - else if target `elem` allFields - then (m, DupChild nt con target (head $ filter (== target) allFields) Seq.<| errs) - else let missing = filter (\s -> not (s `elem` allFields)) sources - in if null missing - then if nt `Set.member` allNts -- check if the nonterm is defined - then (Map.insert target (nt, sources, expr) m, errs) -- all ok.. - else (m, UndefNont nt Seq.<| errs) - else (m, (Seq.fromList $ map (UndefChild nt con) missing) Seq.>< errs) - in foldr checkMerge (Map.empty, Seq.empty) merges - -unionunionplusplus :: Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -unionunionplusplus = Map.unionWith (Map.unionWith (++)) -} - - -{ -mkUniqueRules :: Options -> Map NontermIdent (Map ConstructorIdent [RuleInfo]) -> DataTypes -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Attributes,Attributes) -> NontermIdent -> ConstructorIdent -> Map Identifier Identifier -> [Rule] -mkUniqueRules opts allRules allFields allInsts allAttrDecls nt con usMap - = map apply groups - where - fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allFields) - ++ Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts) - -- may have duplicates - - attrDefs = let projectDefs (_,_,_,defs,_,_,_,_) = defs - in concatMap projectDefs $ Map.findWithDefault [] con $ Map.findWithDefault Map.empty nt allRules - - groups = Map.assocs $ Map.foldrWithKey (\i r m -> Map.insertWith (++) r [i] m) Map.empty usMap - apply (ref,us) = mkRule ref (findOutField ref) us - findOutField ref = case [ chld | (chld, NT tp _ _) <- fields, tp `hasSyn` ref] of - [] -> _LHS - (x:_) -> x - hasSyn tp ref = Map.member ref $ snd $ Map.findWithDefault (Map.empty,Map.empty) tp allAttrDecls - mkRule ref outFld locAttrs - = let locs = filter (not . existsLoc) locAttrs - outAttr = attr outFld ref - defs = (if hasOut then [] else [outAttr]) ++ [attr _LOC u | u <- locs ] - pat = Product noPos defs - rhs = Expression noPos $ wrap ref $ foldr gencase (finalout hasOut locs) locs - -- [HsToken ("mkUniques" ++ show (length locAttrs) ++ " ") noPos, AGField _LHS ref noPos Nothing] - rul = Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False True False Nothing False - hasOut = exists outAttr - exists (Alias fld a _) = (fld,a) `elem` attrDefs - exists _ = False - existsLoc nm = exists (attr _LOC nm) - in rul - attr fld a = Alias fld a (Underscore noPos) - gencase nm outp - = h ("case " ++ uniqueDispenser opts ++ " __cont of { (__cont, " ++ getName nm ++ ") -> ") ++ outp ++ h "}" - h s = [HsToken s noPos] - finalout noGenCont us = h ("(" ++ concat (intersperse "," ( (if noGenCont then [] else ["__cont"]) ++ map getName us)) ++ ")") - wrap ref inp = h "let __cont = " ++ [AGField _LHS ref noPos Nothing] ++ h " in seq __cont ( " ++ inp ++ h " )" -} - - -------------------------------------------------------------------------------- --- Checking RHSs of rules (optional) -------------------------------------------------------------------------------- - -SEM SemDef | Def MergeDef - lhs.errors = if checkParseRhs @lhs.options - then Seq.fromList $ checkRhs @rhs - else Seq.empty - --- type of a type signature - -SEM SemDef | TypeDef - lhs.errors = if checkParseTy @lhs.options - then case @tp of - Haskell s -> let ex = Expression @pos tks - tks = [tk] - tk = HsToken s @pos - in Seq.fromList $ checkTy ex - _ -> Seq.empty - else Seq.empty - -------------------------------------------------------------------------------- --- Collecting fields -------------------------------------------------------------------------------- - -ATTR Fields Field [ | | collectedFields USE {++} {[]} : {[(Identifier, Type)]} ] - -SEM Field | FChild - lhs.collectedFields = [(@name, makeType @lhs.allNonterminals @tp)] - -------------------------------------------------------------------------------- --- Collecting constraints -------------------------------------------------------------------------------- - -ATTR Fields Field [ | | collectedConstraints USE {++} {[]} : {[Type]} ] - -SEM Field | FCtx - lhs.collectedConstraints = @tps - -------------------------------------------------------------------------------- --- Collecting Set names and Nonterminal names -------------------------------------------------------------------------------- - - - -SEM Elem - | Set lhs.collectedSetNames = Set.singleton @name - -SEM Elem - | Type lhs.collectedNames = Set.singleton @name - -SEM NontSet - | NamedSet lhs.collectedNames = Set.singleton @name - -SEM AG - | AG loc.allNonterminals = @elems.collectedNames `Set.difference` @elems.collectedSetNames - - - - - - -SEM ConstructorSet - | CName lhs.collectedConstructorNames = Set.singleton @name - ---SEM Alt --- | Alt lhs.collectedConstructorNames = Set.singleton @name - -SEM Elem - | Data lhs.collectedConstructorsMap = Map.fromList - [ (n, @alts.collectedConstructorNames) - | n <- Set.toList @names.nontSet - ] - -SEM AG - | AG elems.allConstructors = @elems.collectedConstructorsMap - - - -------------------------------------------------------------------------------- --- Type synonyms -------------------------------------------------------------------------------- - -{- At the moment type synonyms are only supported for list types - This means that only synonyms of the form: - TYPE = [ ] - are allowed --} - - -ATTR Elem Elems [ | | typeSyns USE {++} {[]} : {TypeSyns} ] - -{- Put this synonym in the typeSyns list and - add the implicit Cons and Nil productions for the type synonym - - A synonym of the form: - TYPE = [ ] - is translated into: - DATA | Cons hd: tl: - | Nil --} - -SEM Elem - | Type loc.expanded = case @argType of - List tp -> [(Ident "Cons" @pos, [(Ident "hd" @pos, tp) - ,(Ident "tl" @pos, NT @name (map getName @params) False) - ] - ) - ,(Ident "Nil" @pos, []) - ] - Maybe tp -> [(Ident "Just" @pos, [(Ident "just" @pos, tp) - ] - ) - ,(Ident "Nothing" @pos, []) - ] - Either tp1 tp2 -> [ - (Ident "Left" @pos, [(Ident "left" @pos, tp1) ]) - , (Ident "Right" @pos, [(Ident "right" @pos, tp2) ]) - ] - Map tp1 tp2 -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, tp1) - , (Ident "val" @pos, tp2) - , (Ident "tl" @pos, NT @name (map getName @params) False) - ]) - , (Ident "Nil" @pos, []) - ] - IntMap tp -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, Haskell "Int") - , (Ident "val" @pos, tp) - , (Ident "tl" @pos, NT @name (map getName @params) False) - ]) - , (Ident "Nil" @pos, []) - ] - OrdSet tp -> [ (Ident "Entry" @pos, [ (Ident "val" @pos, tp) - , (Ident "tl" @pos, NT @name (map getName @params) False) ]) - , (Ident "Nil" @pos, []) - ] - IntSet -> [ (Ident "Entry" @pos, [ (Ident "val" @pos, Haskell "Int") - , (Ident "tl" @pos, NT @name (map getName @params) False) ]) - , (Ident "Nil" @pos, []) - ] - Tuple xs -> [(Ident "Tuple" @pos, xs)] - loc.argType = case @type of - Maybe tp -> Maybe ( makeType @lhs.allNonterminals tp) - Either tp1 tp2 -> Either ( makeType @lhs.allNonterminals tp1) (makeType @lhs.allNonterminals tp2) - List tp -> List ( makeType @lhs.allNonterminals tp) - Tuple xs -> Tuple [(f,makeType @lhs.allNonterminals tp) | (f,tp) <- xs] - Map tp1 tp2 -> Map ( makeType @lhs.allNonterminals tp1) (makeType @lhs.allNonterminals tp2) - IntMap tp -> IntMap ( makeType @lhs.allNonterminals tp) - OrdSet tp -> OrdSet ( makeType @lhs.allNonterminals tp) - IntSet -> IntSet - lhs.typeSyns = [(@name,@argType)] - -------------------------------------------------------------------------------- --- Interpreting Nonterminal sets -------------------------------------------------------------------------------- - - -SEM AG - | AG - elems.defSets = Map.fromList (map (\x->(x,(Set.singleton x, Set.empty))) (Set.toList @loc.allNonterminals)) - elems.definedSets = Map.map fst @elems.defSets - - -SEM Elem - | Set loc.(defSets2,errs) = let allUsedNames = Set.unions [ maybe (Set.singleton n) - snd - (Map.lookup n @lhs.defSets) - | n <- Set.toList @set.collectedNames - ] - (nontSet,e1) | Set.member @name allUsedNames - = (Set.empty, Seq.singleton(CyclicSet @name)) - | otherwise = (@set.nontSet, Seq.empty) - (res, e2) = let toAdd = (nontSet,Set.insert @name allUsedNames) - un (a,b) (c,d) = (a `Set.union` c, b `Set.union` d) - in if Set.member @name @lhs.allNonterminals || not @merge - then checkDuplicate DupSet @name toAdd @lhs.defSets - else (Map.insertWith un @name toAdd @lhs.defSets, Seq.empty) - in (res, e1 Seq.>< e2) - lhs.defSets = @defSets2 - .errors = @errs >< @set.errors - -SEM NontSet - | All lhs.nontSet = @lhs.allNonterminals - | NamedSet loc.(nontSet,errors) = case Map.lookup @name @lhs.definedSets of - Nothing -> (Set.empty, Seq.singleton (UndefNont @name)) - Just set -> (set, Seq.empty) - | Union lhs.nontSet = Set.union @set1.nontSet @set2.nontSet - | Intersect lhs.nontSet = Set.intersection @set1.nontSet @set2.nontSet - | Difference lhs.nontSet = Set.difference @set1.nontSet @set2.nontSet - | Path lhs.nontSet = let table = flattenDatas @lhs.allFields - in path table @from @to - lhs.errors = let check name | Set.member name @lhs.allNonterminals - = Seq.empty - | otherwise = Seq.singleton (UndefNont name) - in check @from >< check @to - - -{ -flattenDatas :: DataTypes -> Map NontermIdent (Set NontermIdent) -flattenDatas ds = Map.map flatten ds - where flatten cs = Set.fromList [ nt | (_, NT nt _ _) <- concatMap snd (Map.toList cs)] - -reachableFrom :: Map NontermIdent (Set NontermIdent) -> Set NontermIdent -> Set NontermIdent -reachableFrom table = reach - where reach nts = let nts' = Set.unions (nts : [ ns | nt <- Set.toList nts - , let ns = Map.findWithDefault Set.empty nt table ]) - in if Set.size nts' > Set.size nts - then reach nts' - else nts -invert :: Map NontermIdent (Set NontermIdent) -> Map NontermIdent (Set NontermIdent) -invert = foldr inv Map.empty . Map.toList - where inv (x,ns) m = fold (\n m' -> Map.insertWith Set.union n (Set.singleton x) m') m ns - -path :: Map NontermIdent (Set NontermIdent) -> NontermIdent -> NontermIdent -> Set NontermIdent -path table from to = let children = Map.findWithDefault Set.empty from table - forward = reachableFrom table children - backward = reachableFrom (invert table) - (Set.singleton to) - in Set.intersection forward backward -} - -------------------------------------------------------------------------------- --- Interpreting Constructor Sets -------------------------------------------------------------------------------- - - -SEM ConstructorSet - | CName lhs.constructors = \_ -> Set.singleton @name - | CUnion lhs.constructors = \ds -> @set1.constructors ds `Set.union` @set2.constructors ds - | CDifference lhs.constructors = \ds -> @set1.constructors ds `Set.difference` @set2.constructors ds - | CAll lhs.constructors = \ds -> ds - -------------------------------------------------------------------------------- --- Collecting wrappers -------------------------------------------------------------------------------- - -ATTR Elem Elems [ | | wrappers USE {`Set.union`} {Set.empty} :{Set NontermIdent}] - -SEM Elem - | Wrapper lhs.wrappers = @set.nontSet - -------------------------------------------------------------------------------- --- Collecting nocatas -------------------------------------------------------------------------------- - -SEM Elem - | Nocatas lhs.pragmas = \o -> o { nocatas = @set.nontSet `Set.union` nocatas o } - -------------------------------------------------------------------------------- --- Collecting pragmas -------------------------------------------------------------------------------- - -ATTR AG Elem Elems [ | | pragmas USE {.} {id} :{Options -> Options}] - -SEM Elem - | Pragma lhs.pragmas = let mk n o = case getName n of - "gencatas" -> o { folds = True } - "nogencatas" -> o { folds = False } - "gendatas" -> o { dataTypes = True } - "datarecords" -> o { dataRecords = True } - "nogendatas" -> o { dataTypes = False } - "gensems" -> o { semfuns = True } - "nogensems" -> o { semfuns = False } - "gentypesigs" -> o { typeSigs = True } - "nogentypesigs"-> o { typeSigs = False } - "nocycle" -> o { withCycle = False, loag = False } - "cycle" -> o { withCycle = True } - "nostrictdata" -> o { strictData = False } - "strictdata" -> o { strictData = True } - "nostrictcase" -> o { strictCases = False } - "strictcase" -> o { strictCases = True } - "strictercase" -> o { strictCases = True, stricterCases = True } - "nostrictwrap" -> o { strictWrap = False } - "strictwrap" -> o { strictWrap = True } - "novisit" -> o { visit = False, loag = False } - "visit" -> o { visit = True } - "nocase" -> o { cases = False } - "case" -> o { cases = True } - "noseq" -> o { withSeq = False } - "seq" -> o { withSeq = True } - "nounbox" -> o { unbox = False } - "unbox" -> o { unbox = True } - "bangpats" -> o { bangpats = True } - "breadthfirst" -> o { breadthFirst = True } - "breadthfirstStrict" -> o { breadthFirstStrict = True } - "nooptimize" -> o { cases = False , visit = False } - "optimize" -> o { cases = True , visit = True } - "strictsem" -> o { strictSems = True } - "gentraces" -> o { genTraces = True } - "genusetraces" -> o { genUseTraces = True } - "splitsems" -> o { splitSems = True } - "gencostcentres" -> o { genCostCentres = True } - "sepsemmods" -> sepSemModsOpt o - "genlinepragmas" -> o { genLinePragmas = True } - "newtypes" -> o { newtypes = True } - "nonewtypes" -> o { newtypes = False } - "nooptimizations" -> o { noOptimizations = True } - "kennedywarren" -> o { kennedyWarren = True } - "aspectag" -> o { genAspectAG = True } - 'n':'o':'g':'r':'o':'u':'p':'_':atts - -> o { noGroup = extract atts ++ noGroup o } - "rename" -> o { rename = True } - "parallel" -> o { parallelInvoke = True } - "monadicwrappers" -> o { monadicWrappers = True } - - "dummytokenvisit" -> o { dummyTokenVisit = True } - "tupleasdummytoken" -> o { tupleAsDummyToken = True } - "stateasdummytoken" -> o { tupleAsDummyToken = False } - "strictdummytoken" -> o { strictDummyToken = True } - "noperruletypesigs" -> o { noPerRuleTypeSigs = True } - "noperstatetypesigs" -> o { noPerStateTypeSigs = True } - "noeagerblackholing" -> o { noEagerBlackholing = True } - "noperrulecostcentres" -> o { noPerRuleCostCentres = True } - "nopervisitcostcentres" -> o { noPerVisitCostCentres = True } - "helpinlining" -> o { helpInlining = True } - "noinlinepragmas" -> o { noInlinePragmas = True } - "aggressiveinlinepragmas" -> o { aggressiveInlinePragmas = True } - "latehigherorderbindings" -> o { lateHigherOrderBinding = True } - "ocaml" -> ocamlOpt o - "cleanlang" -> cleanOpt o - - s -> trace ("uuagc: ignoring unknown pragma: " ++ s) o - in \o -> foldr mk o @names - -{ -extract :: String -> [String] -extract s = case dropWhile isSeparator s of - "" -> [] - s' -> w : extract s'' - where (w, s'') = break isSeparator s' -isSeparator :: Char -> Bool -isSeparator x = x == '_' -} - -ATTR Elem Elems SemAlts SemAlt [ | | semPragmasCollect USE {`pragmaMapUnion`} {Map.empty} : {PragmaMap} ] - -SEM SemAlt - | SemAlt - loc.pragmaNames = Set.fromList @rules.pragmaNamesCollect - lhs.semPragmasCollect = foldr pragmaMapUnion Map.empty [ pragmaMapSingle nt con @loc.pragmaNames - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - -ATTR SemDefs SemDef [ | | pragmaNamesCollect USE {++} {[]} : {[Identifier]} ] - -SEM SemDef - | SemPragma - lhs.pragmaNamesCollect = @names - -{ -pragmaMapUnion :: PragmaMap -> PragmaMap -> PragmaMap -pragmaMapUnion = Map.unionWith (Map.unionWith Set.union) - -pragmaMapSingle :: NontermIdent -> ConstructorIdent -> Set Identifier -> PragmaMap -pragmaMapSingle nt con nms = Map.singleton nt (Map.singleton con nms) -} - -------------------------------------------------------------------------------- --- Collecting attribute orders -------------------------------------------------------------------------------- - -ATTR Elem Elems SemAlts SemAlt [ | | attrOrderCollect USE {`orderMapUnion`} {Map.empty} : {AttrOrderMap} ] -ATTR Elem Elems SemAlts SemAlt [ allAttrDecls : {Map NontermIdent (Attributes, Attributes)} | | ] - -SEM SemAlt - | SemAlt - loc.attrOrders - = [ orderMapSingle nt con @rules.orderDepsCollect - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - - lhs.attrOrderCollect = foldr orderMapUnion Map.empty @loc.attrOrders - -ATTR SemDefs SemDef [ | | orderDepsCollect USE {`Set.union`} {Set.empty} : {Set Dependency} ] - -SEM SemDef - | AttrOrderBefore - loc.dependency = [ Dependency b a | b <- @before, a <- @after ] - lhs.orderDepsCollect = Set.fromList @loc.dependency - -{ -orderMapUnion :: AttrOrderMap -> AttrOrderMap -> AttrOrderMap -orderMapUnion = Map.unionWith (Map.unionWith Set.union) - -orderMapSingle :: NontermIdent -> ConstructorIdent -> Set Dependency -> AttrOrderMap -orderMapSingle nt con deps = Map.singleton nt (Map.singleton con deps) -} - -------------------------------------------------------------------------------- --- Collecting nonterminal type parameters -------------------------------------------------------------------------------- - -ATTR Elem Elems [ | | paramsCollect USE {`mergeParams`} {Map.empty} : {ParamMap}] - -SEM Elem - | Data - lhs.paramsCollect = if null @params - then Map.empty - else Map.fromList [(nt, @params) | nt <- Set.toList @names.nontSet] - -SEM Elem - | Type - lhs.paramsCollect = if null @params - then Map.empty - else Map.singleton @name @params - -{ -mergeParams :: ParamMap -> ParamMap -> ParamMap -mergeParams = Map.unionWith (++) -} - -------------------------------------------------------------------------------- --- Collecting class contexts of semantic functions -------------------------------------------------------------------------------- - -ATTR Elem Elems [ | | ctxCollect USE {`mergeCtx`} {Map.empty} : {ContextMap}] - -SEM Elem - | Sem Data Attr - lhs.ctxCollect = if null @ctx - then Map.empty - else Map.fromList [(nt, @ctx) | nt <- Set.toList @names.nontSet] - -SEM Elem - | Type - lhs.ctxCollect = if null @ctx - then Map.empty - else Map.singleton @name @ctx - -{ -mergeCtx :: ContextMap -> ContextMap -> ContextMap -mergeCtx - = Map.unionWith nubconcat - where nubconcat a b = nub (a ++ b) -} - -------------------------------------------------------------------------------- --- Collecting quantifiers of semantic functions -------------------------------------------------------------------------------- - -ATTR Elem Elems [ | | quantCollect USE {`mergeQuant`} {Map.empty} : {QuantMap}] - -SEM Elem - | Sem Attr - lhs.quantCollect = if null @quants - then Map.empty - else Map.fromList [(nt, @quants) | nt <- Set.toList @names.nontSet] - -{ -mergeQuant :: QuantMap -> QuantMap -> QuantMap -mergeQuant = Map.unionWith (++) -} - -------------------------------------------------------------------------------- --- Collecting derivings -------------------------------------------------------------------------------- - -ATTR Elem Elems [ | | derivings USE {`mergeDerivings`} {Map.empty} :{Derivings}] - -{ -mergeDerivings :: Derivings -> Derivings -> Derivings -mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1) -} - -SEM Elem - | Deriving lhs.derivings = Map.fromList [(nt,Set.fromList @classes) | nt <- Set.toList @set.nontSet] - -------------------------------------------------------------------------------- --- Collecting ATTR declarations -------------------------------------------------------------------------------- - -{ -merge ::(Ord k, Ord k1) => Map k (Map k1 a) -> Map k (Map k1 a) -> Map k (Map k1 a) -merge x y = foldr f y (Map.toList x) - where f ~(k,v) m = Map.insertWith (Map.union) k v m -} - -SEM AG - | AG elems.attrDecls = Map.empty - -SEM Elem - | Data attrs.nts = @names.nontSet - | Attr attrs.nts = @names.nontSet - | Sem attrs.nts = @names.nontSet - - -SEM Attrs [ nts:{Set NontermIdent} | | ] - | Attrs loc.(attrDecls,errors) = checkAttrs @lhs.allFields (Set.toList @lhs.nts) @inherited @synthesized @lhs.attrDecls - - .(inherited,synthesized,useMap) = let splitAttrs xs = unzip [ ((n,makeType @lhs.allNonterminals t),(n,ud)) - | (n,t,ud) <- xs - ] - (inh,_) = splitAttrs @inh - (chn,uses1) = splitAttrs @chn - (syn,uses2) = splitAttrs @syn - isUse (_,(e1,e2,_)) = not (null e1 || null e2) - in (inh++chn,chn++syn, Map.fromList (Prelude.filter isUse (uses1++uses2))) - lhs.useMap = Map.fromList (zip (Set.toList @lhs.nts) (repeat @useMap)) - - loc.errors1 = if checkParseTy @lhs.options - then let attrs = @inh ++ @syn ++ @chn - items = map (\(ident,tp,_) -> (getPos ident, tp)) attrs - errs = map check items - check (pos,Haskell s) = - let ex = Expression pos tks - tks = [tk] - tk = HsToken s pos - in Seq.fromList $ checkTy ex - check _ = Seq.empty - in foldr (Seq.><) Seq.empty errs - else Seq.empty - lhs.errors = @loc.errors Seq.>< @loc.errors1 - - -{ -checkAttrs :: DataTypes -> [NontermIdent] -> [(Identifier, a)] -> [(Identifier, b)] -> Map NontermIdent (Map Identifier a, Map Identifier b) -> (Map NontermIdent (Map Identifier a, Map Identifier b), Seq Error) -checkAttrs allFields nts inherited synthesized decls' = foldErrors check decls' nts where - check nt decls | not (nt `Map.member` allFields) = (decls,Seq.singleton(UndefNont nt)) - | otherwise = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt decls - (inh',einh) = checkDuplicates (DupInhAttr nt) inherited inh - (syn',esyn) = checkDuplicates (DupSynAttr nt) synthesized syn - in (Map.insert nt (inh',syn') decls,einh >< esyn) -} - - --- Add declaration of self-attribute for each nonterminal: ATTR [ | | self:SELF] -{ -addSelf :: Ord k1 => k1 -> Map k1 (Map k a, Attributes) -> Map k1 (Map k a, Attributes) -addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap - in Map.insert name (eInh, Map.insert (Ident "self" noPos) Self eSyn)atMap -} - - -SEM AG - | AG loc.allAttrDecls = if withSelf @lhs.options - then foldr addSelf @elems.attrDecls (Set.toList @loc.allNonterminals) - else @elems.attrDecls - -------------------------------------------------------------------------------- --- Collecting rules -------------------------------------------------------------------------------- - - -ATTR SemDef SemDefs [ | | ruleInfos USE {++} {[]} : {[RuleInfo]} - sigInfos USE {++} {[]} : {[SigInfo]} - uniqueInfos USE {++} {[]} : {[UniqueInfo]} - augmentInfos USE {++} {[]} : {[AugmentInfo]} - aroundInfos USE {++} {[]} : {[AroundInfo]} - mergeInfos USE {++} {[]} : {[MergeInfo]} - ] - - -SEM SemAlt - | SemAlt loc.coninfo = [ (nt, conset, conkeys) - | nt <- Set.toList @lhs.nts - , let conmap = Map.findWithDefault Map.empty nt @lhs.allFields - , let conkeys = Set.fromList (Map.keys conmap) - , let conset = @constructorSet.constructors conkeys - ] - - lhs.errors = Seq.fromList - [ UndefAlt nt con - | (nt, conset, conkeys) <- @loc.coninfo - , con <- Set.toList (Set.difference conset conkeys) - ] - Seq.>< @rules.errors - lhs.collectedRules - = [ (nt,con,r) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - , r <- @rules.ruleInfos - ] - lhs.collectedSigs - = [ (nt,con,ts) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - , ts <- @rules.sigInfos - ] - - lhs.collectedInsts - = [ (nt,con,@rules.definedInsts) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - - lhs.collectedUniques - = [ (nt,con,@rules.uniqueInfos) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - - lhs.collectedAugments - = [ (nt, con, @rules.augmentInfos) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - - lhs.collectedArounds - = [ (nt, con, @rules.aroundInfos) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - - lhs.collectedMerges - = [ (nt, con, @rules.mergeInfos) - | (nt, conset, _) <- @loc.coninfo - , con <- Set.toList conset - ] - -SEM SemDef - | Def lhs.ruleInfos = [ (@mbName, @pattern.patunder, @rhs, @pattern.definedAttrs, @owrt, show @pattern.stpos, @pure, @eager) ] - -SEM SemDef - | TypeDef lhs.sigInfos = [ (@ident, @tp) ] - -SEM SemDef - | UniqueDef lhs.uniqueInfos = [ (@ident, @ref) ] - -SEM SemDef - | AugmentDef lhs.augmentInfos = [ (@ident, @rhs) ] - -SEM SemDef - | AroundDef lhs.aroundInfos = [ (@ident, @rhs) ] - -SEM SemDef - | MergeDef lhs.mergeInfos = [ (@target, @nt, @sources, @rhs) ] - - -ATTR SemDef SemDefs Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ] -ATTR Pattern Patterns [ | | definedAttrs USE {++} {[]} : {[AttrName]} ] -ATTR Pattern [ | | patunder : {[AttrName]->Pattern} ] -ATTR Patterns [ | | patunder : {[AttrName]->Patterns} ] - -SEM Pattern - | Alias lhs.definedAttrs = (@field, @attr) : @pat.definedAttrs - lhs.patunder = \us -> if ((@field,@attr) `elem` us) then Underscore noPos else @copy - lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts - | Underscore lhs.patunder = \_ -> @copy - | Constr lhs.patunder = \us -> Constr @name (@pats.patunder us) - | Product lhs.patunder = \us -> Product @pos (@pats.patunder us) - | Irrefutable lhs.patunder = \us -> Irrefutable (@pat.patunder us) - -SEM Patterns - | Nil lhs.patunder = \_ -> [] - | Cons lhs.patunder = \us -> (@hd.patunder us) : (@tl.patunder us) - -ATTR Pattern [ | | stpos : Pos ] - -SEM Pattern - | Constr lhs.stpos = getPos @name - | Product lhs.stpos = @pos - | Alias lhs.stpos = getPos @field - | Underscore lhs.stpos = @pos - -------------------------------------------------------------------------------- --- Collect module declaration -------------------------------------------------------------------------------- - -ATTR AG Elems Elem [ | | moduleDecl USE {`flipmplus`} {mzero} : {Maybe (String,String,String)} ] - -SEM Elem - | Module - lhs.moduleDecl = Just (@name, @exports, @imports) - -{ --- We want the last Just in the list -flipmplus = flip mplus -} - -------------------------------------------------------------------------------- --- Constructing transformed syntax tree -------------------------------------------------------------------------------- -{ -makeType :: Set NontermIdent -> Type -> Type -makeType nts tp@(NT x _ _) | Set.member x nts = tp - | otherwise = Haskell (typeToHaskellString Nothing [] tp) -makeType _ tp = tp -} -{ -constructGrammar :: Set NontermIdent - -> ParamMap - -> Map NontermIdent (Map ConstructorIdent (Set Identifier)) - -> DataTypes - -> Map NontermIdent [ConstructorIdent] - -> Map NontermIdent (Map ConstructorIdent [Type]) - -> Map NontermIdent (Attributes, Attributes) - -> Map NontermIdent (Map Identifier (String, String, String)) - -> Derivings - -> Set NontermIdent - -> Map NontermIdent (Map ConstructorIdent [Rule]) - -> Map NontermIdent (Map ConstructorIdent [TypeSig]) - -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) - -> TypeSyns - -> PragmaMap - -> AttrOrderMap - -> ContextMap - -> QuantMap - -> UniqueMap - -> Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) - -> Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) - -> Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) - -> Map NontermIdent (Map ConstructorIdent MaybeMacro) - -> Grammar - -constructGrammar _ ntParams prodParams gram prodOrder constraints attrs uses derivings wrap allrules tsigs allinsts tsyns pragmaMap orderMap contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap macros = - let gr = [ (nt,alts) | (nt,alts) <- Map.toList gram] - nonts = map nont gr - nont (nt,alts) = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt attrs - rmap = Map.findWithDefault Map.empty nt allrules - tsmap = Map.findWithDefault Map.empty nt tsigs - instsmap = Map.findWithDefault Map.empty nt allinsts - params = Map.findWithDefault [] nt ntParams - mergemap = Map.findWithDefault Map.empty nt mergeMap - macromap = Map.findWithDefault Map.empty nt macros - csmap = Map.findWithDefault Map.empty nt constraints - psmap = Map.findWithDefault Map.empty nt prodParams - prs = Map.findWithDefault [] nt prodOrder - alt con = - let flds = Map.findWithDefault [] con alts - rules = Map.findWithDefault [] con rmap - tsigs' = Map.findWithDefault [] con tsmap - insts = Map.findWithDefault [] con instsmap - merges = [ (n, NT t [] False) | (n, (t, _, _)) <- Map.assocs $ maybe Map.empty id (Map.lookup con mergemap) ] - cs = Map.findWithDefault [] con csmap - ps = Set.elems $ Map.findWithDefault Set.empty con psmap - mbMacro = Map.findWithDefault Nothing con macromap - - -- important: keep order of children - cldrn = map child (flds ++ filter (not . existsAsField) insts ++ merges) - child (nm, tp) = - let tpI = if existsAsInst nm - then fromJust $ lookup nm insts - else tp - virt = if existsAsInst nm - then case lookup nm flds of - Just tp' -> ChildReplace tp' - Nothing -> ChildAttr - else if existsAsMerge nm - then ChildAttr - else ChildSyntax - in Child nm tpI virt - existsAsInst nm = maybe False (const True) (lookup nm insts) - existsAsField (nm,_) = maybe False (const True) (lookup nm flds) - existsAsMerge nm = maybe False (const True) (lookup nm merges) - in Production con ps cs cldrn rules tsigs' mbMacro - in Nonterminal nt params inh syn (map alt prs) - in Grammar tsyns uses derivings wrap nonts pragmaMap orderMap ntParams contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap -} - -{ -mapUnionWithSetUnion :: Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -mapUnionWithSetUnion = Map.unionWith Set.union -mapUnionWithPlusPlus :: Map BlockInfo [a] -> Map BlockInfo [a] -> Map BlockInfo [a] -mapUnionWithPlusPlus = Map.unionWith (++) -} - - ---marcos -------------------------------------------------------------------------------- --- Collecting Macro information -------------------------------------------------------------------------------- - -ATTR Alt Alts Elem Elems - [ | | collectedMacros USE {++} {[]} : {[(NontermIdent, ConstructorIdent, MaybeMacro)]}] - - -SEM Alt - | Alt lhs.collectedMacros = [ (nt, con, @macro) - | nt <- Set.toList @lhs.nts - , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) - ] - - -SEM AG - | AG - - loc.allMacros = let f (nt,con,m) = Map.insertWith (Map.union) nt (Map.singleton con m) - in foldr f (Map.empty) @elems.collectedMacros - - -------------------------------------------------------------------------------- --- Collecting the AGI information -------------------------------------------------------------------------------- - -ATTR AG [ | | agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} ] - -ATTR Elem Elems SemAlts SemAlt [ allAttrs : {Map NontermIdent (Attributes, Attributes)} | | ] - -SEM AG - | AG lhs.agi = (@loc.allNonterminals,@loc.allFields,@loc.allAttrs) - - loc.allAttrs = if withSelf @lhs.options - then foldr addSelf @elems.attrs (Set.toList @loc.allNonterminals) - else @elems.attrs - -ATTR Elems Elem Attrs - [ | attrs : {Map NontermIdent (Attributes, Attributes)} | ] - -SEM AG - | AG elems.attrs = Map.empty - - -SEM Attrs - | Attrs lhs.attrs = let ins decls nt = if Map.member nt decls - then Map.update (\(inh,syn) -> Just ( Map.union inh $ Map.fromList @inherited - , Map.union syn $ Map.fromList @synthesized)) nt decls - else Map.insert nt (Map.fromList @inherited, Map.fromList @synthesized) decls - - in foldl ins @lhs.attrs (Set.toList @lhs.nts) - - -------------------------------------------------------------------------------- --- Collecting the data type information -------------------------------------------------------------------------------- - -ATTR AG Elems Elem - [ | | constructorTypeMap USE {`Map.union`} {Map.empty} : {Map NontermIdent ConstructorType} ] - -SEM Elem - | Data lhs.constructorTypeMap = Set.fold (\nm mp -> Map.insert nm @contype mp) Map.empty @names.collectedNames +PRAGMA strictdata +PRAGMA strictwrap + +INCLUDE "ConcreteSyntax.ag" +INCLUDE "Patterns.ag" + +imports +{ +import Control.Monad(mplus,mzero) +import Data.List (partition, nub,intersperse, union) +import Data.Maybe +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Set as Set (Set, member, union, toList, fromList, empty, singleton, member, unions, size, fold, intersection, difference, insert, elems) +import qualified Data.Sequence as Seq +import Data.Sequence(Seq, (><)) +import UU.Scanner.Position(noPos) + +import ConcreteSyntax +import AbstractSyntax +import ErrorMessages +import Patterns (Patterns,Pattern(..)) +import Expression (Expression(..)) +import HsToken + +import RhsCheck +import Debug.Trace +} + + +------------------------------------------------------------------------------- +-- Main goal +------------------------------------------------------------------------------- + +-- Given some options, we want to construct a Grammar, that is, a structure that conforms to AbstractSyntax +ATTR AG [ | | output : Grammar ] +ATTR AG Elems Elem SemAlts SemAlt SemDefs SemDef Attrs [ options : Options | | ] + +-- as a side effect, we generate error messages and Haskell code blocks that need to be embedded in the final code +ATTR AG Elems Elem SemAlts SemAlt Attrs NontSet ConstructorSet SemDefs SemDef + [ | | errors USE {Seq.><}{Seq.empty}:{Seq Error} ] +ATTR AG Elems Elem + [ | | blocks USE {`mapUnionWithPlusPlus`} {Map.empty}: {Blocks} ] + + +-- The output is produced by calling a function that constructs the Grammar, +-- given various datastructures that are collected from the concrete AG. + +SEM AG + | AG lhs.output = constructGrammar @loc.allNonterminals + @elems.paramsCollect + @loc.allConParams + @loc.allFields + @loc.prodOrder + @loc.allConstraints + @loc.allAttrDecls + @elems.useMap + @elems.derivings + (if wrappers @lhs.options then @loc.allNonterminals else @elems.wrappers) + @loc.checkedRules + @loc.checkedSigs + @loc.checkedInsts + @elems.typeSyns + @elems.semPragmasCollect + @elems.attrOrderCollect + @elems.ctxCollect + @elems.quantCollect + @loc.checkedUniques + @loc.checkedAugments + @loc.checkedArounds + @loc.checkedMerges + @loc.allMacros + + +------------------------------------------------------------------------------- +-- Main data flow +------------------------------------------------------------------------------- + +{- Information is collected bottom-up (in multiple phases) + After checking for consistency, datastructures are createad from it, + which are passed down for the other phases. +-} + + +-- Names that are in use + + -- bottom-up collection +ATTR Elem Elems [ | | collectedSetNames USE {`Set.union`} {Set.empty} : {Set Identifier} ] +ATTR Elem Elems NontSet [ | | collectedNames USE {`Set.union`} {Set.empty} : {Set Identifier} ] + -- top-down distribution +ATTR Elem Elems Attrs Alts Alt Fields Field NontSet [ allNonterminals : {Set NontermIdent} | | ] + + +-- Constructors that are in use + -- bottom-up collection +ATTR Alt Alts ConstructorSet [ | | collectedConstructorNames USE {`Set.union`} {Set.empty} : {Set ConstructorIdent} ] +ATTR Elem Elems [ | | collectedConstructorsMap USE {`mapUnionWithSetUnion`} {Map.empty} : {Map NontermIdent (Set ConstructorIdent)} ] + -- top-down distribution +ATTR Elem Elems Alts Alt [ allConstructors : {Map NontermIdent (Set ConstructorIdent)} | | ] + + + +-- Nonterminal sets that are defined +{type DefinedSets = Map Identifier (Set NontermIdent) } + -- bottom-up collection +ATTR Elem Elems + [ | defSets:{Map Identifier (Set NontermIdent,Set Identifier)} | ] + -- top-down distribution +ATTR Elem Elems NontSet + [ definedSets:{DefinedSets} | | ] + + + +-- Interpreting nonterminal sets +ATTR NontSet [ | | nontSet : {Set NontermIdent} ] + + +-- Interpreting constructor sets +ATTR ConstructorSet [ | | constructors : {(Set ConstructorIdent->Set ConstructorIdent)} ] + + + +-- Contextfree structure +{type FieldMap = [(Identifier, Type)] } +{type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) } + -- bottom-up collection +ATTR Alt Alts Elem Elems + [ | | collectedFields USE {++} {[]} : {[(NontermIdent, ConstructorIdent, FieldMap)]} + collectedConstraints USE {++} {[]} : {[(NontermIdent, ConstructorIdent, [Type])]} + collectedConParams USE {++} {[]} : {[(NontermIdent, ConstructorIdent, Set Identifier)]} + ] + -- top-down distribution +ATTR Elem Elems Attrs SemAlt SemAlts NontSet + [ allFields : {DataTypes} | | ] + + + +-- Attribute declarations + -- bottom-up collection +ATTR Elems Elem Attrs + [ + | attrDecls:{Map NontermIdent (Attributes, Attributes)} + | useMap USE {`merge`} {Map.empty}:{Map NontermIdent (Map Identifier (String,String,String))} + ] + + +-- Attribute definitions +{type AttrName = (Identifier,Identifier) } +{type RuleInfo = (Maybe Identifier, [AttrName]->Pattern, Expression, [AttrName], Bool, String, Bool, Bool) } +{type SigInfo = (Identifier,Type) } +{type UniqueInfo = (Identifier,Identifier) } +{type AugmentInfo = (Identifier,Expression)} +{type AroundInfo = (Identifier,Expression)} +{type MergeInfo = (Identifier, Identifier, [Identifier], Expression)} + -- bottom-up collection +ATTR Elem Elems SemAlt SemAlts + [ | | collectedRules USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, RuleInfo)]} + collectedSigs USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, SigInfo) ]} + collectedInsts USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [Identifier]) ]} + collectedUniques USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]} + collectedAugments USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [AugmentInfo]) ]} + collectedArounds USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [AroundInfo]) ]} + collectedMerges USE {++} {[]} : {[ (NontermIdent, ConstructorIdent, [MergeInfo]) ]} + ] + + + +------------------------------------------------------------------------------- +-- Passing nonterminals +------------------------------------------------------------------------------- + +-- Pass the name of the associated nonterminal to everyone +ATTR Alt Alts SemAlt SemAlts [ nts:{Set NontermIdent} | | ] + +SEM Elem + | Data alts.nts = @names.nontSet + | Sem alts.nts = @names.nontSet + + + +------------------------------------------------------------------------------- +-- Calculation of code blocks -- +------------------------------------------------------------------------------- + +SEM Elem + | Txt loc.blockInfo = ( @kind + , @mbNt + ) + loc.blockValue = [(@lines, @pos)] + lhs.blocks = Map.singleton @loc.blockInfo @loc.blockValue + lhs.errors = if checkParseBlock @lhs.options + then let ex = Expression @pos tks + tks = [tk] + tk = HsToken (unlines @lines) @pos + in Seq.fromList $ checkBlock $ ex + else Seq.empty + + +------------------------------------------------------------------------------- +-- Check for duplicates and report error +------------------------------------------------------------------------------- + +{ + +checkDuplicate :: (Identifier -> Identifier -> Error) + -> Identifier -> val -> Map Identifier val -> (Map Identifier val,Seq Error) +checkDuplicate dupError key val m + = case Map.lookupIndex key m of + Just ix -> let (key',_) = Map.elemAt ix m + in (m,Seq.singleton (dupError key key')) + Nothing -> (Map.insert key val m,Seq.empty) + +checkDuplicates :: (Identifier -> Identifier -> Error) + -> [(Identifier, val)] -> Map Identifier val -> (Map Identifier val,Seq Error) +checkDuplicates dupError new m = foldErrors check m new + where check = uncurry (checkDuplicate dupError) + +foldErrors :: (b -> t -> (t, Seq Error)) -> t -> [b] -> (t, Seq Error) +foldErrors f n xs = foldl g (n,Seq.empty) xs + where g ~(e,es) x = let (e',es') = f x e + in (e', es >< es') + + +checkForDuplicates :: (Identifier -> Identifier -> Error) -> [Identifier] -> [Error] +checkForDuplicates _ [] = [] +checkForDuplicates err (x:xs) = let (same,other) = partition (equalId x) xs + in map (err x) same ++ checkForDuplicates err other + +equalId :: Identifier -> Identifier -> Bool +equalId x y = getName x == getName y + +} + +------------------------------------------------------------------------------- +-- Collecting DATA's and type synonyms +------------------------------------------------------------------------------- + + +SEM Alt + | Alt lhs.collectedFields = [ (nt, con, @fields.collectedFields) + | nt <- Set.toList @lhs.nts + , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) + ] + lhs.collectedConstraints = [ (nt, con, @fields.collectedConstraints) + | nt <- Set.toList @lhs.nts + , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) + ] + lhs.collectedConParams = [ (nt, con, Set.fromList @tyvars) + | nt <- Set.toList @lhs.nts + , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) + ] + +SEM Elem + | Type lhs.collectedFields = map (\(x,y)->(@name, x, y)) @loc.expanded + +SEM AG + | AG + loc.prodOrder = let f (nt,con,_) = Map.insertWith g nt [con] + g [con] lst | con `elem` lst = lst + | otherwise = con : lst + g _ _ = error "This is not possible" + in foldr f Map.empty @elems.collectedFields + loc.allFields = let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm) + in foldr f (Map.empty) @elems.collectedFields + + loc.allConstraints = let f (nt,con,fm) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con fm) + in foldr f (Map.empty) @elems.collectedConstraints + + loc.allConParams = let f (nt,con,fm) = Map.insertWith (Map.unionWith Set.union) nt (Map.singleton con fm) + in foldr f (Map.empty) @elems.collectedConParams + + loc.allConstrs = let f (nt,con,_) = Map.insertWith (++) nt [con] + in foldr f (Map.empty) @elems.collectedFields + + loc.allRules = let f (nt,con,r) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [r]) + in foldr f (Map.empty) @elems.collectedRules + + loc.allSigs = let f (nt,con,t) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con [t]) + typeof nt r = Map.findWithDefault (Haskell "") r $ fst $ Map.findWithDefault (Map.empty,Map.empty) nt @loc.allAttrDecls + in foldr f (Map.empty) ( @elems.collectedSigs + ++ [ (nt, con, (ident,typeof nt ref)) | (nt, con, us) <- @elems.collectedUniques, (ident,ref) <- us ] + ) + + loc.allInsts = let f (nt,con,is) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con is) + in foldr f (Map.empty) @elems.collectedInsts + + loc.allUniques = let f (nt,con,us) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con us) + in foldr f (Map.empty) @elems.collectedUniques + loc.allAugments = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as) + in foldr f Map.empty @elems.collectedAugments + loc.allArounds = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as) + in foldr f Map.empty @elems.collectedArounds + loc.allMerges = let f (nt,con,as) = Map.insertWith (Map.unionWith (++)) nt (Map.singleton con as) + in foldr f Map.empty @elems.collectedMerges + + loc.augmentSigs = let gen _ = [] -- TODO: generate type signatures here for the augments + in Map.map (Map.map gen) @loc.allAugments + + loc.allRulesErrs = Map.mapWithKey (Map.mapWithKey . (checkRules @allAttrDecls @allFields @allInsts @loc.allSigs @loc.allMerges)) @loc.allRules + loc.allNamesErrs = Map.mapWithKey (Map.mapWithKey . checkRuleNames) @loc.allRules + loc.allSigsErrs = Map.mapWithKey (Map.mapWithKey . (checkSigs )) @loc.allSigs + loc.allInstsErrs = Map.mapWithKey (Map.mapWithKey . (checkInsts @loc.allNonterminals @loc.allSigs @allFields )) @loc.allInsts + loc.allUniquesErrs = Map.mapWithKey (Map.mapWithKey . (checkUniques @allAttrDecls )) @loc.allUniques + loc.allAugmentErrs = Map.mapWithKey (Map.mapWithKey . (checkAugments @allAttrDecls )) @loc.allAugments + loc.allAroundsErrs = Map.mapWithKey (Map.mapWithKey . (checkArounds @loc.allFields)) @loc.allArounds + loc.allMergesErrs = Map.mapWithKey (Map.mapWithKey . (checkMerges @loc.allNonterminals @loc.allInsts @loc.allFields)) @loc.allMerges + + loc.checkedRulesPre = Map.map (Map.map fst) @loc.allRulesErrs + loc.checkedSigs = Map.map (Map.map fst) @loc.allSigsErrs `unionunionplusplus` @loc.augmentSigs + loc.checkedInsts = Map.map (Map.map fst) @loc.allInstsErrs + loc.checkedUniques = Map.map (Map.map fst) @loc.allUniquesErrs + loc.checkedAugments = Map.map (Map.map fst) @loc.allAugmentErrs + loc.checkedArounds = Map.map (Map.map fst) @loc.allAroundsErrs + loc.checkedRules = Map.unionWith (Map.unionWith (++)) @loc.checkedRulesPre (Map.mapWithKey (Map.mapWithKey . (mkUniqueRules @lhs.options @loc.allRules @loc.allFields @loc.checkedInsts @loc.allAttrDecls)) @loc.checkedUniques) + loc.checkedMerges = Map.map (Map.map fst) @loc.allMergesErrs + + loc.errs1 = let f = checkForDuplicates (DupSynonym) + in Seq.fromList . f . map fst $ @elems.typeSyns -- forbid duplicate type synonyms + + loc.errs2 = let g nt (con,fm) = checkForDuplicates (DupChild nt con) (map fst fm) + f (nt,cfm) = concat . map (g nt) . Map.toList $ cfm + in Seq.fromList . concat . map f . Map.toList $ @allFields -- forbid duplicate fields + + loc.errs3 = let -- f (nt,cons) = checkForDuplicates (DupAlt nt) cons + in Seq.empty -- allow duplicate constructors, merging their fields + -- Seq.fromList . concat . map f . Map.toList $ @allConstrs -- forbid duplicate constructors + + loc.errs4 = let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty @loc.allRulesErrs + + loc.errs5 = let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty @loc.allSigsErrs + + loc.errs6 = let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty @loc.allInstsErrs + + loc.errs7 = let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty @loc.allUniquesErrs + + loc.errs8 = let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty @loc.allAugmentErrs + + loc.errs9 = let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty @loc.allAroundsErrs + + loc.errs10 = let f m s = Map.foldr ((><)) s m + in Map.foldr f Seq.empty @loc.allNamesErrs + + loc.errs11 = let f m s = Map.foldr ((><) . snd) s m + in Map.foldr f Seq.empty @loc.allMergesErrs + + lhs.errors = @elems.errors >< @errs1 >< @errs2 >< @errs3 >< @errs4 >< @errs5 >< @errs6 >< @errs7 >< @errs8 >< @errs9 >< @errs10 >< @errs11 + +{ +type RulesAndErrors = ([Rule], Seq Error) +type SigsAndErrors = ([TypeSig], Seq Error) +type InstsAndErrors = ([(Identifier, Type)], Seq Error) +type UniquesAndErrors = (Map Identifier Identifier, Seq Error) +type AugmentsAndErrors = (Map Identifier [Expression], Seq Error) +type AroundsAndErrors = (Map Identifier [Expression], Seq Error) +type MergesAndErrors = (Map Identifier (Identifier, [Identifier], Expression), Seq Error) +type AttrOverwrite = Map AttrName Bool +type AccumRuleCheck = (RulesAndErrors, AttrOverwrite) +type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName]) + +checkRules :: Map NontermIdent (Attributes, Attributes) -> DataTypes -> + Map NontermIdent (Map ConstructorIdent [Identifier]) -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> + Map NontermIdent (Map ConstructorIdent [MergeInfo]) -> + NontermIdent -> ConstructorIdent -> [RuleInfo] -> RulesAndErrors +checkRules attributes fields allinsts allsigs _ nt con rs + = let fieldmap :: FieldMap + fieldmap = (_LHS, NT nt [] False) : (_LOC, NT nullIdent [] False) : (_INST, NT nullIdent [] False) : (_FIRST, NT nullIdent [] False) : (_LAST, NT nullIdent [] False) + : Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fields) + ++ mapMaybe (\instNm -> lookup instNm sigs >>= \tp -> return (instNm, tp)) (Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allinsts)) + -- merged children are not allowed to have any inherited attrs defined: do not include + + sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allsigs) + + hasAttrib f tp attr = Map.member attr (f (Map.findWithDefault (Map.empty,Map.empty) tp attributes)) + + checkRule :: RuleInfo -> AccumRuleCheck -> AccumRuleCheck + checkRule (mbNm, pat,ex,as,owrt,str, pur, eager) ((r1,e1),m1) + = let (e2,m2,u2,_) = foldr (checkDefi owrt) (e1,m1,[],[]) as + in ( (Rule mbNm (pat u2) ex owrt str True pur False Nothing eager : r1, e2), m2) + + checkDefi :: Bool -> AttrName -> AccumDefiCheck -> AccumDefiCheck + checkDefi owrt fa@(field,attr) (e,m,u,bs) + = case lookup field fieldmap + of Just (NT tp _ _) -> + let tp' = maybe tp id (deforestedNt tp) + in if field == _LOC || field == _INST || field == _FIRST || field == _LAST + || hasAttrib (if getName field==getName _LHS then snd else fst) tp' attr + then case Map.lookupIndex fa m of + Just ix -> let ((_,attr2),b) = Map.elemAt ix m + in if b && not (fa `elem` bs) + then ( e, Map.insert fa owrt m, fa:u, fa:bs) + else (((Seq.<|)) (DupRule nt con field attr2 attr) e, m, fa:u, bs) + Nothing -> ( e, Map.insert fa owrt m, u, fa:bs) + else (((Seq.<|)) (SuperfluousRule nt con field attr) e, m, fa:u, bs) + _ -> (((Seq.<|)) (UndefChild nt con field) e, m, fa:u, bs ) + + in fst (foldr checkRule (([],Seq.empty),Map.empty) rs) + +checkRuleNames :: NontermIdent -> ConstructorIdent -> [RuleInfo] -> Seq Error +checkRuleNames nt con + = fst . foldr checkRule (Seq.empty, Set.empty) + where + checkRule (Just nm,_,_,_,_,_,_,_) (errs, nms) + | nm `Set.member` nms = (DupRuleName nt con nm Seq.<| errs, nms) + | otherwise = (errs, Set.insert nm nms) + checkRule (Nothing,_,_,_,_,_,_,_) inp = inp + +checkSigs :: NontermIdent -> ConstructorIdent -> [SigInfo] -> SigsAndErrors +checkSigs nt con sis + = let checkSig (ide,typ) (sigs,errs) + = if ide `elem` map (\(TypeSig n _)-> n) sigs + then (sigs, ((Seq.<|)) (DupSig nt con ide) errs) + -- else if not (ide `elem` locattrdefs) + -- then (sigs, ((Seq.<|)) (SupSig nt con ide) errs) + else (TypeSig ide typ:sigs, errs) + in foldr checkSig ([],Seq.empty) sis + +checkInsts :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [Identifier] -> InstsAndErrors +checkInsts allNts sigMap _ nt con + = foldr (\inst (insts, errs) -> + maybe (insts, Seq.singleton (MissingInstSig nt con inst) >< errs) + (\info@(k, NT nm args _) -> + case findInst k insts of + Just k' -> (insts, Seq.singleton (DupChild nt con k k') >< errs) + Nothing -> case nm `Set.member` allNts of + True -> (info : insts, errs) + False | take 2 (getName nm) == "T_" -> let nm' = Ident (drop 2 (getName nm)) (getPos nm) + info' = (k, NT nm' args True) -- this should be the only place at which 'for' with value True can be generated + in case nm' `Set.member` allNts of + True -> (info' : insts, errs) + False -> (insts, Seq.singleton (UndefNont nm') >< errs) + | otherwise -> (insts, Seq.singleton (UndefNont nm) >< errs) + ) + $ findSig inst + ) ([], Seq.empty) + where + sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt sigMap) + + findSig name + = do tp@(NT _ _ _) <- lookup name sigs + return (name, tp) + + findInst _ [] = Nothing + findInst k ((k', _): r) + | k == k' = Just k' + | otherwise = findInst k r + +checkUniques :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [UniqueInfo] -> UniquesAndErrors +checkUniques allAttrs nt con uniques + = let checkUnique (ident,ref) (us,errs) + = if ident `Map.member` us + then (us, ((Seq.<|)) (DupUnique nt con ident) errs) + else if Map.member ref inhs && Map.member ref syns + then (Map.insert ident ref us, errs) + else (us, ((Seq.<|)) (MissingUnique nt ref) errs) + + (inhs,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs + in foldr checkUnique (Map.empty, Seq.empty) uniques + +checkAugments :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [AugmentInfo] -> AugmentsAndErrors +checkAugments allAttrs nt _ augments + = let checkAugment (ident,expr) (as,errs) + = if ident `Map.member` as + then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs) + else if Map.member ident syns + then (Map.insert ident [expr] as, errs) + else (as, ((Seq.<|)) (MissingSyn nt ident) errs) + + (_,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs + in foldr checkAugment (Map.empty, Seq.empty) augments + +checkArounds :: DataTypes -> NontermIdent -> ConstructorIdent -> [AroundInfo] -> AroundsAndErrors +checkArounds fieldMap nt con arounds + = let checkAround (ident,expr) (as,errs) + = if ident `Map.member` as + then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs) + else case lookup ident fields of + Just (NT _ _ _) -> (Map.insert ident [expr] as, errs) + _ -> (as, ((Seq.<|)) (UndefChild nt con ident) errs) + fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap) + in foldr checkAround (Map.empty, Seq.empty) arounds + +checkMerges :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [Identifier]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [MergeInfo] -> MergesAndErrors +checkMerges allNts allInsts fieldMap _ con merges + = let checkMerge (target,nt,sources,expr) (m,errs) + = let fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap) + insts = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts) + allFields = insts ++ map fst fields -- note: sources of merge may not contain a target (for simplicity) + in if target `Map.member` m -- check for duplicate with self + then (m, DupChild nt con target (fst $ Map.elemAt (Map.findIndex target m) m) Seq.<| errs) + else if target `elem` allFields + then (m, DupChild nt con target (head $ filter (== target) allFields) Seq.<| errs) + else let missing = filter (\s -> not (s `elem` allFields)) sources + in if null missing + then if nt `Set.member` allNts -- check if the nonterm is defined + then (Map.insert target (nt, sources, expr) m, errs) -- all ok.. + else (m, UndefNont nt Seq.<| errs) + else (m, (Seq.fromList $ map (UndefChild nt con) missing) Seq.>< errs) + in foldr checkMerge (Map.empty, Seq.empty) merges + +unionunionplusplus :: Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) +unionunionplusplus = Map.unionWith (Map.unionWith (++)) +} + + +{ +mkUniqueRules :: Options -> Map NontermIdent (Map ConstructorIdent [RuleInfo]) -> DataTypes -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Attributes,Attributes) -> NontermIdent -> ConstructorIdent -> Map Identifier Identifier -> [Rule] +mkUniqueRules opts allRules allFields allInsts allAttrDecls nt con usMap + = map apply groups + where + fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allFields) + ++ Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts) + -- may have duplicates + + attrDefs = let projectDefs (_,_,_,defs,_,_,_,_) = defs + in concatMap projectDefs $ Map.findWithDefault [] con $ Map.findWithDefault Map.empty nt allRules + + groups = Map.assocs $ Map.foldrWithKey (\i r m -> Map.insertWith (++) r [i] m) Map.empty usMap + apply (ref,us) = mkRule ref (findOutField ref) us + findOutField ref = case [ chld | (chld, NT tp _ _) <- fields, tp `hasSyn` ref] of + [] -> _LHS + (x:_) -> x + hasSyn tp ref = Map.member ref $ snd $ Map.findWithDefault (Map.empty,Map.empty) tp allAttrDecls + mkRule ref outFld locAttrs + = let locs = filter (not . existsLoc) locAttrs + outAttr = attr outFld ref + defs = (if hasOut then [] else [outAttr]) ++ [attr _LOC u | u <- locs ] + pat = Product noPos defs + rhs = Expression noPos $ wrap ref $ foldr gencase (finalout hasOut locs) locs + -- [HsToken ("mkUniques" ++ show (length locAttrs) ++ " ") noPos, AGField _LHS ref noPos Nothing] + rul = Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False True False Nothing False + hasOut = exists outAttr + exists (Alias fld a _) = (fld,a) `elem` attrDefs + exists _ = False + existsLoc nm = exists (attr _LOC nm) + in rul + attr fld a = Alias fld a (Underscore noPos) + gencase nm outp + = h ("case " ++ uniqueDispenser opts ++ " __cont of { (__cont, " ++ getName nm ++ ") -> ") ++ outp ++ h "}" + h s = [HsToken s noPos] + finalout noGenCont us = h ("(" ++ concat (intersperse "," ( (if noGenCont then [] else ["__cont"]) ++ map getName us)) ++ ")") + wrap ref inp = h "let __cont = " ++ [AGField _LHS ref noPos Nothing] ++ h " in seq __cont ( " ++ inp ++ h " )" +} + + +------------------------------------------------------------------------------- +-- Checking RHSs of rules (optional) +------------------------------------------------------------------------------- + +SEM SemDef | Def MergeDef + lhs.errors = if checkParseRhs @lhs.options + then Seq.fromList $ checkRhs @rhs + else Seq.empty + +-- type of a type signature + +SEM SemDef | TypeDef + lhs.errors = if checkParseTy @lhs.options + then case @tp of + Haskell s -> let ex = Expression @pos tks + tks = [tk] + tk = HsToken s @pos + in Seq.fromList $ checkTy ex + _ -> Seq.empty + else Seq.empty + +------------------------------------------------------------------------------- +-- Collecting fields +------------------------------------------------------------------------------- + +ATTR Fields Field [ | | collectedFields USE {++} {[]} : {[(Identifier, Type)]} ] + +SEM Field | FChild + lhs.collectedFields = [(@name, makeType @lhs.allNonterminals @tp)] + +------------------------------------------------------------------------------- +-- Collecting constraints +------------------------------------------------------------------------------- + +ATTR Fields Field [ | | collectedConstraints USE {++} {[]} : {[Type]} ] + +SEM Field | FCtx + lhs.collectedConstraints = @tps + +------------------------------------------------------------------------------- +-- Collecting Set names and Nonterminal names +------------------------------------------------------------------------------- + + + +SEM Elem + | Set lhs.collectedSetNames = Set.singleton @name + +SEM Elem + | Type lhs.collectedNames = Set.singleton @name + +SEM NontSet + | NamedSet lhs.collectedNames = Set.singleton @name + +SEM AG + | AG loc.allNonterminals = @elems.collectedNames `Set.difference` @elems.collectedSetNames + + + + + + +SEM ConstructorSet + | CName lhs.collectedConstructorNames = Set.singleton @name + +--SEM Alt +-- | Alt lhs.collectedConstructorNames = Set.singleton @name + +SEM Elem + | Data lhs.collectedConstructorsMap = Map.fromList + [ (n, @alts.collectedConstructorNames) + | n <- Set.toList @names.nontSet + ] + +SEM AG + | AG elems.allConstructors = @elems.collectedConstructorsMap + + + +------------------------------------------------------------------------------- +-- Type synonyms +------------------------------------------------------------------------------- + +{- At the moment type synonyms are only supported for list types + This means that only synonyms of the form: + TYPE = [ ] + are allowed +-} + + +ATTR Elem Elems [ | | typeSyns USE {++} {[]} : {TypeSyns} ] + +{- Put this synonym in the typeSyns list and + add the implicit Cons and Nil productions for the type synonym + + A synonym of the form: + TYPE = [ ] + is translated into: + DATA | Cons hd: tl: + | Nil +-} + +SEM Elem + | Type loc.expanded = case @argType of + List tp -> [(Ident "Cons" @pos, [(Ident "hd" @pos, tp) + ,(Ident "tl" @pos, NT @name (map getName @params) False) + ] + ) + ,(Ident "Nil" @pos, []) + ] + Maybe tp -> [(Ident "Just" @pos, [(Ident "just" @pos, tp) + ] + ) + ,(Ident "Nothing" @pos, []) + ] + Either tp1 tp2 -> [ + (Ident "Left" @pos, [(Ident "left" @pos, tp1) ]) + , (Ident "Right" @pos, [(Ident "right" @pos, tp2) ]) + ] + Map tp1 tp2 -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, tp1) + , (Ident "val" @pos, tp2) + , (Ident "tl" @pos, NT @name (map getName @params) False) + ]) + , (Ident "Nil" @pos, []) + ] + IntMap tp -> [ (Ident "Entry" @pos, [ (Ident "key" @pos, Haskell "Int") + , (Ident "val" @pos, tp) + , (Ident "tl" @pos, NT @name (map getName @params) False) + ]) + , (Ident "Nil" @pos, []) + ] + OrdSet tp -> [ (Ident "Entry" @pos, [ (Ident "val" @pos, tp) + , (Ident "tl" @pos, NT @name (map getName @params) False) ]) + , (Ident "Nil" @pos, []) + ] + IntSet -> [ (Ident "Entry" @pos, [ (Ident "val" @pos, Haskell "Int") + , (Ident "tl" @pos, NT @name (map getName @params) False) ]) + , (Ident "Nil" @pos, []) + ] + Tuple xs -> [(Ident "Tuple" @pos, xs)] + loc.argType = case @type of + Maybe tp -> Maybe ( makeType @lhs.allNonterminals tp) + Either tp1 tp2 -> Either ( makeType @lhs.allNonterminals tp1) (makeType @lhs.allNonterminals tp2) + List tp -> List ( makeType @lhs.allNonterminals tp) + Tuple xs -> Tuple [(f,makeType @lhs.allNonterminals tp) | (f,tp) <- xs] + Map tp1 tp2 -> Map ( makeType @lhs.allNonterminals tp1) (makeType @lhs.allNonterminals tp2) + IntMap tp -> IntMap ( makeType @lhs.allNonterminals tp) + OrdSet tp -> OrdSet ( makeType @lhs.allNonterminals tp) + IntSet -> IntSet + lhs.typeSyns = [(@name,@argType)] + +------------------------------------------------------------------------------- +-- Interpreting Nonterminal sets +------------------------------------------------------------------------------- + + +SEM AG + | AG + elems.defSets = Map.fromList (map (\x->(x,(Set.singleton x, Set.empty))) (Set.toList @loc.allNonterminals)) + elems.definedSets = Map.map fst @elems.defSets + + +SEM Elem + | Set loc.(defSets2,errs) = let allUsedNames = Set.unions [ maybe (Set.singleton n) + snd + (Map.lookup n @lhs.defSets) + | n <- Set.toList @set.collectedNames + ] + (nontSet,e1) | Set.member @name allUsedNames + = (Set.empty, Seq.singleton(CyclicSet @name)) + | otherwise = (@set.nontSet, Seq.empty) + (res, e2) = let toAdd = (nontSet,Set.insert @name allUsedNames) + un (a,b) (c,d) = (a `Set.union` c, b `Set.union` d) + in if Set.member @name @lhs.allNonterminals || not @merge + then checkDuplicate DupSet @name toAdd @lhs.defSets + else (Map.insertWith un @name toAdd @lhs.defSets, Seq.empty) + in (res, e1 Seq.>< e2) + lhs.defSets = @defSets2 + .errors = @errs >< @set.errors + +SEM NontSet + | All lhs.nontSet = @lhs.allNonterminals + | NamedSet loc.(nontSet,errors) = case Map.lookup @name @lhs.definedSets of + Nothing -> (Set.empty, Seq.singleton (UndefNont @name)) + Just set -> (set, Seq.empty) + | Union lhs.nontSet = Set.union @set1.nontSet @set2.nontSet + | Intersect lhs.nontSet = Set.intersection @set1.nontSet @set2.nontSet + | Difference lhs.nontSet = Set.difference @set1.nontSet @set2.nontSet + | Path lhs.nontSet = let table = flattenDatas @lhs.allFields + in path table @from @to + lhs.errors = let check name | Set.member name @lhs.allNonterminals + = Seq.empty + | otherwise = Seq.singleton (UndefNont name) + in check @from >< check @to + + +{ +flattenDatas :: DataTypes -> Map NontermIdent (Set NontermIdent) +flattenDatas ds = Map.map flatten ds + where flatten cs = Set.fromList [ nt | (_, NT nt _ _) <- concatMap snd (Map.toList cs)] + +reachableFrom :: Map NontermIdent (Set NontermIdent) -> Set NontermIdent -> Set NontermIdent +reachableFrom table = reach + where reach nts = let nts' = Set.unions (nts : [ ns | nt <- Set.toList nts + , let ns = Map.findWithDefault Set.empty nt table ]) + in if Set.size nts' > Set.size nts + then reach nts' + else nts +invert :: Map NontermIdent (Set NontermIdent) -> Map NontermIdent (Set NontermIdent) +invert = foldr inv Map.empty . Map.toList + where inv (x,ns) m = fold (\n m' -> Map.insertWith Set.union n (Set.singleton x) m') m ns + +path :: Map NontermIdent (Set NontermIdent) -> NontermIdent -> NontermIdent -> Set NontermIdent +path table from to = let children = Map.findWithDefault Set.empty from table + forward = reachableFrom table children + backward = reachableFrom (invert table) + (Set.singleton to) + in Set.intersection forward backward +} + +------------------------------------------------------------------------------- +-- Interpreting Constructor Sets +------------------------------------------------------------------------------- + + +SEM ConstructorSet + | CName lhs.constructors = \_ -> Set.singleton @name + | CUnion lhs.constructors = \ds -> @set1.constructors ds `Set.union` @set2.constructors ds + | CDifference lhs.constructors = \ds -> @set1.constructors ds `Set.difference` @set2.constructors ds + | CAll lhs.constructors = \ds -> ds + +------------------------------------------------------------------------------- +-- Collecting wrappers +------------------------------------------------------------------------------- + +ATTR Elem Elems [ | | wrappers USE {`Set.union`} {Set.empty} :{Set NontermIdent}] + +SEM Elem + | Wrapper lhs.wrappers = @set.nontSet + +------------------------------------------------------------------------------- +-- Collecting nocatas +------------------------------------------------------------------------------- + +SEM Elem + | Nocatas lhs.pragmas = \o -> o { nocatas = @set.nontSet `Set.union` nocatas o } + +------------------------------------------------------------------------------- +-- Collecting pragmas +------------------------------------------------------------------------------- + +ATTR AG Elem Elems [ | | pragmas USE {.} {id} :{Options -> Options}] + +SEM Elem + | Pragma lhs.pragmas = let mk n o = case getName n of + "gencatas" -> o { folds = True } + "nogencatas" -> o { folds = False } + "gendatas" -> o { dataTypes = True } + "datarecords" -> o { dataRecords = True } + "nogendatas" -> o { dataTypes = False } + "gensems" -> o { semfuns = True } + "nogensems" -> o { semfuns = False } + "gentypesigs" -> o { typeSigs = True } + "nogentypesigs"-> o { typeSigs = False } + "nocycle" -> o { withCycle = False, loag = False } + "cycle" -> o { withCycle = True } + "nostrictdata" -> o { strictData = False } + "strictdata" -> o { strictData = True } + "nostrictcase" -> o { strictCases = False } + "strictcase" -> o { strictCases = True } + "strictercase" -> o { strictCases = True, stricterCases = True } + "nostrictwrap" -> o { strictWrap = False } + "strictwrap" -> o { strictWrap = True } + "novisit" -> o { visit = False, loag = False } + "visit" -> o { visit = True } + "nocase" -> o { cases = False } + "case" -> o { cases = True } + "noseq" -> o { withSeq = False } + "seq" -> o { withSeq = True } + "nounbox" -> o { unbox = False } + "unbox" -> o { unbox = True } + "bangpats" -> o { bangpats = True } + "breadthfirst" -> o { breadthFirst = True } + "breadthfirstStrict" -> o { breadthFirstStrict = True } + "nooptimize" -> o { cases = False , visit = False } + "optimize" -> o { cases = True , visit = True } + "strictsem" -> o { strictSems = True } + "gentraces" -> o { genTraces = True } + "genusetraces" -> o { genUseTraces = True } + "splitsems" -> o { splitSems = True } + "gencostcentres" -> o { genCostCentres = True } + "sepsemmods" -> sepSemModsOpt o + "genlinepragmas" -> o { genLinePragmas = True } + "newtypes" -> o { newtypes = True } + "nonewtypes" -> o { newtypes = False } + "nooptimizations" -> o { noOptimizations = True } + "kennedywarren" -> o { kennedyWarren = True } + "aspectag" -> o { genAspectAG = True } + 'n':'o':'g':'r':'o':'u':'p':'_':atts + -> o { noGroup = extract atts ++ noGroup o } + "rename" -> o { rename = True } + "parallel" -> o { parallelInvoke = True } + "monadicwrappers" -> o { monadicWrappers = True } + + "dummytokenvisit" -> o { dummyTokenVisit = True } + "tupleasdummytoken" -> o { tupleAsDummyToken = True } + "stateasdummytoken" -> o { tupleAsDummyToken = False } + "strictdummytoken" -> o { strictDummyToken = True } + "noperruletypesigs" -> o { noPerRuleTypeSigs = True } + "noperstatetypesigs" -> o { noPerStateTypeSigs = True } + "noeagerblackholing" -> o { noEagerBlackholing = True } + "noperrulecostcentres" -> o { noPerRuleCostCentres = True } + "nopervisitcostcentres" -> o { noPerVisitCostCentres = True } + "helpinlining" -> o { helpInlining = True } + "noinlinepragmas" -> o { noInlinePragmas = True } + "aggressiveinlinepragmas" -> o { aggressiveInlinePragmas = True } + "latehigherorderbindings" -> o { lateHigherOrderBinding = True } + "ocaml" -> ocamlOpt o + "cleanlang" -> cleanOpt o + + s -> trace ("uuagc: ignoring unknown pragma: " ++ s) o + in \o -> foldr mk o @names + +{ +extract :: String -> [String] +extract s = case dropWhile isSeparator s of + "" -> [] + s' -> w : extract s'' + where (w, s'') = break isSeparator s' +isSeparator :: Char -> Bool +isSeparator x = x == '_' +} + +ATTR Elem Elems SemAlts SemAlt [ | | semPragmasCollect USE {`pragmaMapUnion`} {Map.empty} : {PragmaMap} ] + +SEM SemAlt + | SemAlt + loc.pragmaNames = Set.fromList @rules.pragmaNamesCollect + lhs.semPragmasCollect = foldr pragmaMapUnion Map.empty [ pragmaMapSingle nt con @loc.pragmaNames + | (nt, conset, _) <- @loc.coninfo + , con <- Set.toList conset + ] + +ATTR SemDefs SemDef [ | | pragmaNamesCollect USE {++} {[]} : {[Identifier]} ] + +SEM SemDef + | SemPragma + lhs.pragmaNamesCollect = @names + +{ +pragmaMapUnion :: PragmaMap -> PragmaMap -> PragmaMap +pragmaMapUnion = Map.unionWith (Map.unionWith Set.union) + +pragmaMapSingle :: NontermIdent -> ConstructorIdent -> Set Identifier -> PragmaMap +pragmaMapSingle nt con nms = Map.singleton nt (Map.singleton con nms) +} + +------------------------------------------------------------------------------- +-- Collecting attribute orders +------------------------------------------------------------------------------- + +ATTR Elem Elems SemAlts SemAlt [ | | attrOrderCollect USE {`orderMapUnion`} {Map.empty} : {AttrOrderMap} ] +ATTR Elem Elems SemAlts SemAlt [ allAttrDecls : {Map NontermIdent (Attributes, Attributes)} | | ] + +SEM SemAlt + | SemAlt + loc.attrOrders + = [ orderMapSingle nt con @rules.orderDepsCollect + | (nt, conset, _) <- @loc.coninfo + , con <- Set.toList conset + ] + + lhs.attrOrderCollect = foldr orderMapUnion Map.empty @loc.attrOrders + +ATTR SemDefs SemDef [ | | orderDepsCollect USE {`Set.union`} {Set.empty} : {Set Dependency} ] + +SEM SemDef + | AttrOrderBefore + loc.dependency = [ Dependency b a | b <- @before, a <- @after ] + lhs.orderDepsCollect = Set.fromList @loc.dependency + +{ +orderMapUnion :: AttrOrderMap -> AttrOrderMap -> AttrOrderMap +orderMapUnion = Map.unionWith (Map.unionWith Set.union) + +orderMapSingle :: NontermIdent -> ConstructorIdent -> Set Dependency -> AttrOrderMap +orderMapSingle nt con deps = Map.singleton nt (Map.singleton con deps) +} + +------------------------------------------------------------------------------- +-- Collecting nonterminal type parameters +------------------------------------------------------------------------------- + +ATTR Elem Elems [ | | paramsCollect USE {`mergeParams`} {Map.empty} : {ParamMap}] + +SEM Elem + | Data + lhs.paramsCollect = if null @params + then Map.empty + else Map.fromList [(nt, @params) | nt <- Set.toList @names.nontSet] + +SEM Elem + | Type + lhs.paramsCollect = if null @params + then Map.empty + else Map.singleton @name @params + +{ +mergeParams :: ParamMap -> ParamMap -> ParamMap +mergeParams = Map.unionWith (++) +} + +------------------------------------------------------------------------------- +-- Collecting class contexts of semantic functions +------------------------------------------------------------------------------- + +ATTR Elem Elems [ | | ctxCollect USE {`mergeCtx`} {Map.empty} : {ContextMap}] + +SEM Elem + | Sem Data Attr + lhs.ctxCollect = if null @ctx + then Map.empty + else Map.fromList [(nt, @ctx) | nt <- Set.toList @names.nontSet] + +SEM Elem + | Type + lhs.ctxCollect = if null @ctx + then Map.empty + else Map.singleton @name @ctx + +{ +mergeCtx :: ContextMap -> ContextMap -> ContextMap +mergeCtx + = Map.unionWith nubconcat + where nubconcat a b = nub (a ++ b) +} + +------------------------------------------------------------------------------- +-- Collecting quantifiers of semantic functions +------------------------------------------------------------------------------- + +ATTR Elem Elems [ | | quantCollect USE {`mergeQuant`} {Map.empty} : {QuantMap}] + +SEM Elem + | Sem Attr + lhs.quantCollect = if null @quants + then Map.empty + else Map.fromList [(nt, @quants) | nt <- Set.toList @names.nontSet] + +{ +mergeQuant :: QuantMap -> QuantMap -> QuantMap +mergeQuant = Map.unionWith (++) +} + +------------------------------------------------------------------------------- +-- Collecting derivings +------------------------------------------------------------------------------- + +ATTR Elem Elems [ | | derivings USE {`mergeDerivings`} {Map.empty} :{Derivings}] + +{ +mergeDerivings :: Derivings -> Derivings -> Derivings +mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1) +} + +SEM Elem + | Deriving lhs.derivings = Map.fromList [(nt,Set.fromList @classes) | nt <- Set.toList @set.nontSet] + +------------------------------------------------------------------------------- +-- Collecting ATTR declarations +------------------------------------------------------------------------------- + +{ +merge ::(Ord k, Ord k1) => Map k (Map k1 a) -> Map k (Map k1 a) -> Map k (Map k1 a) +merge x y = foldr f y (Map.toList x) + where f ~(k,v) m = Map.insertWith (Map.union) k v m +} + +SEM AG + | AG elems.attrDecls = Map.empty + +SEM Elem + | Data attrs.nts = @names.nontSet + | Attr attrs.nts = @names.nontSet + | Sem attrs.nts = @names.nontSet + + +SEM Attrs [ nts:{Set NontermIdent} | | ] + | Attrs loc.(attrDecls,errors) = checkAttrs @lhs.allFields (Set.toList @lhs.nts) @inherited @synthesized @lhs.attrDecls + + .(inherited,synthesized,useMap) = let splitAttrs xs = unzip [ ((n,makeType @lhs.allNonterminals t),(n,ud)) + | (n,t,ud) <- xs + ] + (inh,_) = splitAttrs @inh + (chn,uses1) = splitAttrs @chn + (syn,uses2) = splitAttrs @syn + isUse (_,(e1,e2,_)) = not (null e1 || null e2) + in (inh++chn,chn++syn, Map.fromList (Prelude.filter isUse (uses1++uses2))) + lhs.useMap = Map.fromList (zip (Set.toList @lhs.nts) (repeat @useMap)) + + loc.errors1 = if checkParseTy @lhs.options + then let attrs = @inh ++ @syn ++ @chn + items = map (\(ident,tp,_) -> (getPos ident, tp)) attrs + errs = map check items + check (pos,Haskell s) = + let ex = Expression pos tks + tks = [tk] + tk = HsToken s pos + in Seq.fromList $ checkTy ex + check _ = Seq.empty + in foldr (Seq.><) Seq.empty errs + else Seq.empty + lhs.errors = @loc.errors Seq.>< @loc.errors1 + + +{ +checkAttrs :: DataTypes -> [NontermIdent] -> [(Identifier, a)] -> [(Identifier, b)] -> Map NontermIdent (Map Identifier a, Map Identifier b) -> (Map NontermIdent (Map Identifier a, Map Identifier b), Seq Error) +checkAttrs allFields nts inherited synthesized decls' = foldErrors check decls' nts where + check nt decls | not (nt `Map.member` allFields) = (decls,Seq.singleton(UndefNont nt)) + | otherwise = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt decls + (inh',einh) = checkDuplicates (DupInhAttr nt) inherited inh + (syn',esyn) = checkDuplicates (DupSynAttr nt) synthesized syn + in (Map.insert nt (inh',syn') decls,einh >< esyn) +} + + +-- Add declaration of self-attribute for each nonterminal: ATTR [ | | self:SELF] +{ +addSelf :: Ord k1 => k1 -> Map k1 (Map k a, Attributes) -> Map k1 (Map k a, Attributes) +addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap + in Map.insert name (eInh, Map.insert (Ident "self" noPos) Self eSyn)atMap +} + + +SEM AG + | AG loc.allAttrDecls = if withSelf @lhs.options + then foldr addSelf @elems.attrDecls (Set.toList @loc.allNonterminals) + else @elems.attrDecls + +------------------------------------------------------------------------------- +-- Collecting rules +------------------------------------------------------------------------------- + + +ATTR SemDef SemDefs [ | | ruleInfos USE {++} {[]} : {[RuleInfo]} + sigInfos USE {++} {[]} : {[SigInfo]} + uniqueInfos USE {++} {[]} : {[UniqueInfo]} + augmentInfos USE {++} {[]} : {[AugmentInfo]} + aroundInfos USE {++} {[]} : {[AroundInfo]} + mergeInfos USE {++} {[]} : {[MergeInfo]} + ] + + +SEM SemAlt + | SemAlt loc.coninfo = [ (nt, conset, conkeys) + | nt <- Set.toList @lhs.nts + , let conmap = Map.findWithDefault Map.empty nt @lhs.allFields + , let conkeys = Set.fromList (Map.keys conmap) + , let conset = @constructorSet.constructors conkeys + ] + + lhs.errors = Seq.fromList + [ UndefAlt nt con + | (nt, conset, conkeys) <- @loc.coninfo + , con <- Set.toList (Set.difference conset conkeys) + ] + Seq.>< @rules.errors + lhs.collectedRules + = [ (nt,con,r) + | (nt, conset, _) <- @loc.coninfo + , con <- Set.toList conset + , r <- @rules.ruleInfos + ] + lhs.collectedSigs + = [ (nt,con,ts) + | (nt, conset, _) <- @loc.coninfo + , con <- Set.toList conset + , ts <- @rules.sigInfos + ] + + lhs.collectedInsts + = [ (nt,con,@rules.definedInsts) + | (nt, conset, _) <- @loc.coninfo + , con <- Set.toList conset + ] + + lhs.collectedUniques + = [ (nt,con,@rules.uniqueInfos) + | (nt, conset, _) <- @loc.coninfo + , con <- Set.toList conset + ] + + lhs.collectedAugments + = [ (nt, con, @rules.augmentInfos) + | (nt, conset, _) <- @loc.coninfo + , con <- Set.toList conset + ] + + lhs.collectedArounds + = [ (nt, con, @rules.aroundInfos) + | (nt, conset, _) <- @loc.coninfo + , con <- Set.toList conset + ] + + lhs.collectedMerges + = [ (nt, con, @rules.mergeInfos) + | (nt, conset, _) <- @loc.coninfo + , con <- Set.toList conset + ] + +SEM SemDef + | Def lhs.ruleInfos = [ (@mbName, @pattern.patunder, @rhs, @pattern.definedAttrs, @owrt, show @pattern.stpos, @pure, @eager) ] + +SEM SemDef + | TypeDef lhs.sigInfos = [ (@ident, @tp) ] + +SEM SemDef + | UniqueDef lhs.uniqueInfos = [ (@ident, @ref) ] + +SEM SemDef + | AugmentDef lhs.augmentInfos = [ (@ident, @rhs) ] + +SEM SemDef + | AroundDef lhs.aroundInfos = [ (@ident, @rhs) ] + +SEM SemDef + | MergeDef lhs.mergeInfos = [ (@target, @nt, @sources, @rhs) ] + + +ATTR SemDef SemDefs Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ] +ATTR Pattern Patterns [ | | definedAttrs USE {++} {[]} : {[AttrName]} ] +ATTR Pattern [ | | patunder : {[AttrName]->Pattern} ] +ATTR Patterns [ | | patunder : {[AttrName]->Patterns} ] + +SEM Pattern + | Alias lhs.definedAttrs = (@field, @attr) : @pat.definedAttrs + lhs.patunder = \us -> if ((@field,@attr) `elem` us) then Underscore noPos else @copy + lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts + | Underscore lhs.patunder = \_ -> @copy + | Constr lhs.patunder = \us -> Constr @name (@pats.patunder us) + | Product lhs.patunder = \us -> Product @pos (@pats.patunder us) + | Irrefutable lhs.patunder = \us -> Irrefutable (@pat.patunder us) + +SEM Patterns + | Nil lhs.patunder = \_ -> [] + | Cons lhs.patunder = \us -> (@hd.patunder us) : (@tl.patunder us) + +ATTR Pattern [ | | stpos : Pos ] + +SEM Pattern + | Constr lhs.stpos = getPos @name + | Product lhs.stpos = @pos + | Alias lhs.stpos = getPos @field + | Underscore lhs.stpos = @pos + +------------------------------------------------------------------------------- +-- Collect module declaration +------------------------------------------------------------------------------- + +ATTR AG Elems Elem [ | | moduleDecl USE {`flipmplus`} {mzero} : {Maybe (String,String,String)} ] + +SEM Elem + | Module + lhs.moduleDecl = Just (@name, @exports, @imports) + +{ +-- We want the last Just in the list +flipmplus = flip mplus +} + +------------------------------------------------------------------------------- +-- Constructing transformed syntax tree +------------------------------------------------------------------------------- +{ +makeType :: Set NontermIdent -> Type -> Type +makeType nts tp@(NT x _ _) | Set.member x nts = tp + | otherwise = Haskell (typeToHaskellString Nothing [] tp) +makeType _ tp = tp +} +{ +constructGrammar :: Set NontermIdent + -> ParamMap + -> Map NontermIdent (Map ConstructorIdent (Set Identifier)) + -> DataTypes + -> Map NontermIdent [ConstructorIdent] + -> Map NontermIdent (Map ConstructorIdent [Type]) + -> Map NontermIdent (Attributes, Attributes) + -> Map NontermIdent (Map Identifier (String, String, String)) + -> Derivings + -> Set NontermIdent + -> Map NontermIdent (Map ConstructorIdent [Rule]) + -> Map NontermIdent (Map ConstructorIdent [TypeSig]) + -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) + -> TypeSyns + -> PragmaMap + -> AttrOrderMap + -> ContextMap + -> QuantMap + -> UniqueMap + -> Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) + -> Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) + -> Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) + -> Map NontermIdent (Map ConstructorIdent MaybeMacro) + -> Grammar + +constructGrammar _ ntParams prodParams gram prodOrder constraints attrs uses derivings wrap allrules tsigs allinsts tsyns pragmaMap orderMap contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap macros = + let gr = [ (nt,alts) | (nt,alts) <- Map.toList gram] + nonts = map nont gr + nont (nt,alts) = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt attrs + rmap = Map.findWithDefault Map.empty nt allrules + tsmap = Map.findWithDefault Map.empty nt tsigs + instsmap = Map.findWithDefault Map.empty nt allinsts + params = Map.findWithDefault [] nt ntParams + mergemap = Map.findWithDefault Map.empty nt mergeMap + macromap = Map.findWithDefault Map.empty nt macros + csmap = Map.findWithDefault Map.empty nt constraints + psmap = Map.findWithDefault Map.empty nt prodParams + prs = Map.findWithDefault [] nt prodOrder + alt con = + let flds = Map.findWithDefault [] con alts + rules = Map.findWithDefault [] con rmap + tsigs' = Map.findWithDefault [] con tsmap + insts = Map.findWithDefault [] con instsmap + merges = [ (n, NT t [] False) | (n, (t, _, _)) <- Map.assocs $ maybe Map.empty id (Map.lookup con mergemap) ] + cs = Map.findWithDefault [] con csmap + ps = Set.elems $ Map.findWithDefault Set.empty con psmap + mbMacro = Map.findWithDefault Nothing con macromap + + -- important: keep order of children + cldrn = map child (flds ++ filter (not . existsAsField) insts ++ merges) + child (nm, tp) = + let tpI = if existsAsInst nm + then fromJust $ lookup nm insts + else tp + virt = if existsAsInst nm + then case lookup nm flds of + Just tp' -> ChildReplace tp' + Nothing -> ChildAttr + else if existsAsMerge nm + then ChildAttr + else ChildSyntax + in Child nm tpI virt + existsAsInst nm = maybe False (const True) (lookup nm insts) + existsAsField (nm,_) = maybe False (const True) (lookup nm flds) + existsAsMerge nm = maybe False (const True) (lookup nm merges) + in Production con ps cs cldrn rules tsigs' mbMacro + in Nonterminal nt params inh syn (map alt prs) + in Grammar tsyns uses derivings wrap nonts pragmaMap orderMap ntParams contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap +} + +{ +mapUnionWithSetUnion :: Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) +mapUnionWithSetUnion = Map.unionWith Set.union +mapUnionWithPlusPlus :: Map BlockInfo [a] -> Map BlockInfo [a] -> Map BlockInfo [a] +mapUnionWithPlusPlus = Map.unionWith (++) +} + + +--marcos +------------------------------------------------------------------------------- +-- Collecting Macro information +------------------------------------------------------------------------------- + +ATTR Alt Alts Elem Elems + [ | | collectedMacros USE {++} {[]} : {[(NontermIdent, ConstructorIdent, MaybeMacro)]}] + + +SEM Alt + | Alt lhs.collectedMacros = [ (nt, con, @macro) + | nt <- Set.toList @lhs.nts + , con <- Set.toList (@names.constructors (Map.findWithDefault Set.empty nt @lhs.allConstructors)) + ] + + +SEM AG + | AG + + loc.allMacros = let f (nt,con,m) = Map.insertWith (Map.union) nt (Map.singleton con m) + in foldr f (Map.empty) @elems.collectedMacros + + +------------------------------------------------------------------------------- +-- Collecting the AGI information +------------------------------------------------------------------------------- + +ATTR AG [ | | agi : {(Set NontermIdent, DataTypes, Map NontermIdent (Attributes, Attributes))} ] + +ATTR Elem Elems SemAlts SemAlt [ allAttrs : {Map NontermIdent (Attributes, Attributes)} | | ] + +SEM AG + | AG lhs.agi = (@loc.allNonterminals,@loc.allFields,@loc.allAttrs) + + loc.allAttrs = if withSelf @lhs.options + then foldr addSelf @elems.attrs (Set.toList @loc.allNonterminals) + else @elems.attrs + +ATTR Elems Elem Attrs + [ | attrs : {Map NontermIdent (Attributes, Attributes)} | ] + +SEM AG + | AG elems.attrs = Map.empty + + +SEM Attrs + | Attrs lhs.attrs = let ins decls nt = if Map.member nt decls + then Map.update (\(inh,syn) -> Just ( Map.union inh $ Map.fromList @inherited + , Map.union syn $ Map.fromList @synthesized)) nt decls + else Map.insert nt (Map.fromList @inherited, Map.fromList @synthesized) decls + + in foldl ins @lhs.attrs (Set.toList @lhs.nts) + + +------------------------------------------------------------------------------- +-- Collecting the data type information +------------------------------------------------------------------------------- + +ATTR AG Elems Elem + [ | | constructorTypeMap USE {`Map.union`} {Map.empty} : {Map NontermIdent ConstructorType} ] + +SEM Elem + | Data lhs.constructorTypeMap = Set.fold (\nm mp -> Map.insert nm @contype mp) Map.empty @names.collectedNames diff --git a/src-ag/Visage.ag b/src-ag/Visage.ag --- a/src-ag/Visage.ag +++ b/src-ag/Visage.ag @@ -1,122 +1,122 @@ -INCLUDE "VisageSyntax.ag" -INCLUDE "VisagePatterns.ag" -INCLUDE "Expression.ag" - - -imports { -import UU.Scanner.Position(Pos(..)) -import CommonTypes -import ATermAbstractSyntax -import Expression -import VisagePatterns -import VisageSyntax -import qualified Data.Map as Map -import Data.Map(Map) -import Data.List(intersperse) -import TokenDef -} - -{ -convert :: String -> String -convert [] = [] -convert (c:ct) | c == '\n' = '\\' : 'n' : convert ct - | otherwise = c : convert ct - -sQ :: String -> String -sQ [] = [] -sQ (x:xs) = if (x=='"') then rest else x:rest - where - rest = if not (null xs) && last xs == '"' then init xs else xs - -showAGPos :: Pos -> String -showAGPos (Pos l c f) | l == (-1) = "" - | otherwise = let file = if null f then "" else f -- No show of f - lc = "(line " ++ show l ++ ", column " ++ show c ++")" - in file ++ lc - -showMap :: (Show a, Show b) => Map a b -> String -showMap - = braces . concat . intersperse "," . map (uncurry assign) . Map.assocs - where - braces s = "{" ++ s ++ "}" - assign a b = show a ++ ":=" ++ show b -} - -WRAPPER VisageGrammar - -ATTR VisageGrammar VisageNonterminal VisageProduction - VisageChild VisageRule Expression VisagePattern [ || aterm:{ATerm} ] -ATTR VisageNonterminals VisageProductions VisageChildren - VisageRules VisagePatterns [ || aterms:{[ATerm]} ] -ATTR VisageRules -> VisageRule [ isLoc : Bool | | ] - -SEM VisageGrammar - | VGrammar lhs.aterm = AAppl "Productions" @nonts.aterms - - -SEM VisageNonterminals - | Cons lhs.aterms = @hd.aterm : @tl.aterms - | Nil lhs.aterms = [] - - -SEM VisageNonterminal - | VNonterminal lhs.aterm = AAppl "Production" [AString (sQ (getName @nt)), AString (sQ(showMap @inh)), - AString (sQ(showMap @syn)), AAppl "Alternatives" @alts.aterms] - - -SEM VisageProductions - | Cons lhs.aterms = @hd.aterm : @tl.aterms - | Nil lhs.aterms = [] - - -SEM VisageProduction - | VProduction lhs.aterm = AAppl "Alternative" [AString (sQ (getName @con)), AAppl "Children" @children.aterms, - AAppl "Rules" @rules.aterms, - AAppl "LocRules" @locrules.aterms] - locrules.isLoc = True - rules.isLoc = False - -SEM VisageChildren - | Cons lhs.aterms = @hd.aterm : @tl.aterms - | Nil lhs.aterms = [] - - -SEM VisageChild - | VChild lhs.aterm = AAppl "Child" [AString (sQ (getName @name)), AString (sQ (show @tp)), - AString (sQ (showMap @inh)), - AString (sQ (showMap @syn)), - AAppl "Rules" @rules.aterms] - rules.isLoc = False - -SEM VisageRules - | Cons lhs.aterms = @hd.aterm : @tl.aterms - | Nil lhs.aterms = [] - - -SEM VisageRule - | VRule lhs.aterm = AAppl (if @lhs.isLoc then "LocRule" else "Rule") - ([AString (sQ (getName @attr)), @pat.aterm, @rhs.aterm] ++ if @lhs.isLoc then [AString (sQ (show @owrt))] else []) - - - -SEM Expression - | Expression lhs.aterm = AAppl "Expression" [AString (sQ (showAGPos @pos)), AString (sQ (unlines . showTokens . tokensToStrings $ @tks))] - - -SEM VisagePatterns - | Cons lhs.aterms = @hd.aterm : @tl.aterms - | Nil lhs.aterms = [] - - -SEM VisagePattern - | VConstr lhs.aterm = AAppl "Pattern" [AAppl "Constr" [AString (sQ (showAGPos (getPos @name))), - AString (sQ (getName @name)), - AAppl "Patterns" @pats.aterms]] - | VProduct lhs.aterm = AAppl "Pattern" [AAppl "Product" [AString (sQ (showAGPos @pos)), - AAppl "Patterns" @pats.aterms]] - | VVar lhs.aterm = AAppl "Pattern" [AAppl "Var" [AString (sQ (showAGPos (getPos @field))), - AString (sQ (getName @field ++ "." ++ getName @attr))]] - | VAlias lhs.aterm = AAppl "Pattern" [AAppl "Alias" [AString (sQ (showAGPos (getPos @field))), - AString (sQ (getName @field ++ "." ++ getName @attr)), @pat.aterm]] - | VUnderscore lhs.aterm = AAppl "Pattern" [AAppl "Underscore" [AString (sQ (showAGPos @pos))]] - +INCLUDE "VisageSyntax.ag" +INCLUDE "VisagePatterns.ag" +INCLUDE "Expression.ag" + + +imports { +import UU.Scanner.Position(Pos(..)) +import CommonTypes +import ATermAbstractSyntax +import Expression +import VisagePatterns +import VisageSyntax +import qualified Data.Map as Map +import Data.Map(Map) +import Data.List(intersperse) +import TokenDef +} + +{ +convert :: String -> String +convert [] = [] +convert (c:ct) | c == '\n' = '\\' : 'n' : convert ct + | otherwise = c : convert ct + +sQ :: String -> String +sQ [] = [] +sQ (x:xs) = if (x=='"') then rest else x:rest + where + rest = if not (null xs) && last xs == '"' then init xs else xs + +showAGPos :: Pos -> String +showAGPos (Pos l c f) | l == (-1) = "" + | otherwise = let file = if null f then "" else f -- No show of f + lc = "(line " ++ show l ++ ", column " ++ show c ++")" + in file ++ lc + +showMap :: (Show a, Show b) => Map a b -> String +showMap + = braces . concat . intersperse "," . map (uncurry assign) . Map.assocs + where + braces s = "{" ++ s ++ "}" + assign a b = show a ++ ":=" ++ show b +} + +WRAPPER VisageGrammar + +ATTR VisageGrammar VisageNonterminal VisageProduction + VisageChild VisageRule Expression VisagePattern [ || aterm:{ATerm} ] +ATTR VisageNonterminals VisageProductions VisageChildren + VisageRules VisagePatterns [ || aterms:{[ATerm]} ] +ATTR VisageRules -> VisageRule [ isLoc : Bool | | ] + +SEM VisageGrammar + | VGrammar lhs.aterm = AAppl "Productions" @nonts.aterms + + +SEM VisageNonterminals + | Cons lhs.aterms = @hd.aterm : @tl.aterms + | Nil lhs.aterms = [] + + +SEM VisageNonterminal + | VNonterminal lhs.aterm = AAppl "Production" [AString (sQ (getName @nt)), AString (sQ(showMap @inh)), + AString (sQ(showMap @syn)), AAppl "Alternatives" @alts.aterms] + + +SEM VisageProductions + | Cons lhs.aterms = @hd.aterm : @tl.aterms + | Nil lhs.aterms = [] + + +SEM VisageProduction + | VProduction lhs.aterm = AAppl "Alternative" [AString (sQ (getName @con)), AAppl "Children" @children.aterms, + AAppl "Rules" @rules.aterms, + AAppl "LocRules" @locrules.aterms] + locrules.isLoc = True + rules.isLoc = False + +SEM VisageChildren + | Cons lhs.aterms = @hd.aterm : @tl.aterms + | Nil lhs.aterms = [] + + +SEM VisageChild + | VChild lhs.aterm = AAppl "Child" [AString (sQ (getName @name)), AString (sQ (show @tp)), + AString (sQ (showMap @inh)), + AString (sQ (showMap @syn)), + AAppl "Rules" @rules.aterms] + rules.isLoc = False + +SEM VisageRules + | Cons lhs.aterms = @hd.aterm : @tl.aterms + | Nil lhs.aterms = [] + + +SEM VisageRule + | VRule lhs.aterm = AAppl (if @lhs.isLoc then "LocRule" else "Rule") + ([AString (sQ (getName @attr)), @pat.aterm, @rhs.aterm] ++ if @lhs.isLoc then [AString (sQ (show @owrt))] else []) + + + +SEM Expression + | Expression lhs.aterm = AAppl "Expression" [AString (sQ (showAGPos @pos)), AString (sQ (unlines . showTokens . tokensToStrings $ @tks))] + + +SEM VisagePatterns + | Cons lhs.aterms = @hd.aterm : @tl.aterms + | Nil lhs.aterms = [] + + +SEM VisagePattern + | VConstr lhs.aterm = AAppl "Pattern" [AAppl "Constr" [AString (sQ (showAGPos (getPos @name))), + AString (sQ (getName @name)), + AAppl "Patterns" @pats.aterms]] + | VProduct lhs.aterm = AAppl "Pattern" [AAppl "Product" [AString (sQ (showAGPos @pos)), + AAppl "Patterns" @pats.aterms]] + | VVar lhs.aterm = AAppl "Pattern" [AAppl "Var" [AString (sQ (showAGPos (getPos @field))), + AString (sQ (getName @field ++ "." ++ getName @attr))]] + | VAlias lhs.aterm = AAppl "Pattern" [AAppl "Alias" [AString (sQ (showAGPos (getPos @field))), + AString (sQ (getName @field ++ "." ++ getName @attr)), @pat.aterm]] + | VUnderscore lhs.aterm = AAppl "Pattern" [AAppl "Underscore" [AString (sQ (showAGPos @pos))]] + diff --git a/src-ag/VisagePatterns.ag b/src-ag/VisagePatterns.ag --- a/src-ag/VisagePatterns.ag +++ b/src-ag/VisagePatterns.ag @@ -1,19 +1,19 @@ -imports -{ -import UU.Scanner.Position(Pos) -import CommonTypes -} - -TYPE VisagePatterns = [VisagePattern] - -DATA VisagePattern | VConstr name : {ConstructorIdent} - pats : VisagePatterns - | VProduct pos : {Pos} - pats : VisagePatterns - | VVar field : {Identifier} - attr : {Identifier} - | VAlias field : {Identifier} - attr : {Identifier} - pat : VisagePattern - | VUnderscore pos : {Pos} - +imports +{ +import UU.Scanner.Position(Pos) +import CommonTypes +} + +TYPE VisagePatterns = [VisagePattern] + +DATA VisagePattern | VConstr name : {ConstructorIdent} + pats : VisagePatterns + | VProduct pos : {Pos} + pats : VisagePatterns + | VVar field : {Identifier} + attr : {Identifier} + | VAlias field : {Identifier} + attr : {Identifier} + pat : VisagePattern + | VUnderscore pos : {Pos} + diff --git a/src-ag/VisageSyntax.ag b/src-ag/VisageSyntax.ag --- a/src-ag/VisageSyntax.ag +++ b/src-ag/VisageSyntax.ag @@ -1,42 +1,42 @@ -imports -{ -import CommonTypes -import UU.Pretty -import AbstractSyntax -import VisagePatterns -import Expression -} - -DATA VisageGrammar | VGrammar nonts : VisageNonterminals - -TYPE VisageNonterminals = [VisageNonterminal] - -TYPE VisageProductions = [VisageProduction] - -TYPE VisageChildren = [VisageChild] - -TYPE VisageRules = [VisageRule] - -DATA VisageNonterminal | VNonterminal nt : {NontermIdent} - inh : {Attributes} - syn : {Attributes} - alts : VisageProductions - -DATA VisageProduction | VProduction con : {ConstructorIdent} - children : VisageChildren - rules : VisageRules - locrules : VisageRules - - -DATA VisageChild | VChild name : {Identifier} - tp : {Type} - inh : {Attributes} - syn : {Attributes} - rules : VisageRules - -DATA VisageRule | VRule fieldattrs : {[(Identifier,Identifier)]} - attr : {Identifier} - pat : VisagePattern - rhs : Expression - owrt : {Bool} - +imports +{ +import CommonTypes +import UU.Pretty +import AbstractSyntax +import VisagePatterns +import Expression +} + +DATA VisageGrammar | VGrammar nonts : VisageNonterminals + +TYPE VisageNonterminals = [VisageNonterminal] + +TYPE VisageProductions = [VisageProduction] + +TYPE VisageChildren = [VisageChild] + +TYPE VisageRules = [VisageRule] + +DATA VisageNonterminal | VNonterminal nt : {NontermIdent} + inh : {Attributes} + syn : {Attributes} + alts : VisageProductions + +DATA VisageProduction | VProduction con : {ConstructorIdent} + children : VisageChildren + rules : VisageRules + locrules : VisageRules + + +DATA VisageChild | VChild name : {Identifier} + tp : {Type} + inh : {Attributes} + syn : {Attributes} + rules : VisageRules + +DATA VisageRule | VRule fieldattrs : {[(Identifier,Identifier)]} + attr : {Identifier} + pat : VisagePattern + rhs : Expression + owrt : {Bool} + diff --git a/src-generated/AG2AspectAG.hs b/src-generated/AG2AspectAG.hs --- a/src-generated/AG2AspectAG.hs +++ b/src-generated/AG2AspectAG.hs @@ -3,380 +3,380 @@ module AG2AspectAG where {-# LINE 2 "src-ag/HsToken.ag" #-} - -import CommonTypes -import UU.Scanner.Position(Pos) + +import CommonTypes +import UU.Scanner.Position(Pos) {-# LINE 10 "src-generated/AG2AspectAG.hs" #-} {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 16 "src-generated/AG2AspectAG.hs" #-} {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 23 "src-generated/AG2AspectAG.hs" #-} {-# LINE 2 "src-ag/AbstractSyntax.ag" #-} - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import Macro --marcos -import CommonTypes -import ErrorMessages + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import Macro --marcos +import CommonTypes +import ErrorMessages {-# LINE 35 "src-generated/AG2AspectAG.hs" #-} {-# LINE 8 "src-ag/AG2AspectAG.ag" #-} - -import Options - -import Data.Char -import Data.List -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Maybe - -import Pretty -import PPUtil -import UU.Scanner.Position - -import AbstractSyntax -import TokenDef -import CommonTypes - --- import Debug.Trace + +import Options + +import Data.Char +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Maybe + +import Pretty +import PPUtil +import UU.Scanner.Position + +import AbstractSyntax +import TokenDef +import CommonTypes + +-- import Debug.Trace {-# LINE 56 "src-generated/AG2AspectAG.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 28 "src-ag/AG2AspectAG.ag" #-} - -pragmaAspectAG = pp "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}" - + +pragmaAspectAG = pp "{-# LANGUAGE EmptyDataDecls, NoMonomorphismRestriction , TypeSynonymInstances, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}" + {-# LINE 63 "src-generated/AG2AspectAG.hs" #-} {-# LINE 33 "src-ag/AG2AspectAG.ag" #-} - -ppName l = ppListSep "" "" "_" l + +ppName l = ppListSep "" "" "_" l {-# LINE 68 "src-generated/AG2AspectAG.hs" #-} {-# LINE 70 "src-ag/AG2AspectAG.ag" #-} - -type FieldMap = [(Identifier, Type)] -type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) + +type FieldMap = [(Identifier, Type)] +type DataTypes = Map.Map NontermIdent (Map.Map ConstructorIdent FieldMap) {-# LINE 74 "src-generated/AG2AspectAG.hs" #-} {-# LINE 342 "src-ag/AG2AspectAG.ag" #-} - -filterAtts newAtts = filter (\att -> Map.member (identifier att) newAtts) -filterNotAtts newAtts = filter (\att -> not (Map.member (identifier att) newAtts)) - -defAtt att = "data " >|< attTName att >|< "; " >|< attName att >|< " = proxy :: Proxy " >|< attTName att -attName att = pp $ "att_" ++ att -attTName att = pp $ "Att_" ++ att - - -defAttRec recPref ppNt atts noGroup = - let recName = ppName [recPref, ppNt] - fields = ppCommas (map (\(a,t) -> ppName [pp a, recName ] >|< " ::" >|< ppShow t) (groupAtts atts noGroup)) - in - "data " >|< recName >|< " = " >|< recName >|< " { " >|< fields >|< " }" - -groupAtts atts noGroup = (Map.toAscList . Map.difference atts) noGroup - --- it defines selectors with the form: --- l1_nt_prod(x, _, .., _) = x --- ln_nt_prod(_, .., _, x) = x -defLocalAtts prodName total actual (l:ls) = ppName [pp l, prodName] >|< - ppListSep "(" ")" "," (replicate (actual-1) "_" ++ "x" : replicate (total-actual) "_") >|< - pp " = x" >-< - defLocalAtts prodName total (actual+1) ls -defLocalAtts _ _ _ [] = empty - + +filterAtts newAtts = filter (\att -> Map.member (identifier att) newAtts) +filterNotAtts newAtts = filter (\att -> not (Map.member (identifier att) newAtts)) + +defAtt att = "data " >|< attTName att >|< "; " >|< attName att >|< " = proxy :: Proxy " >|< attTName att +attName att = pp $ "att_" ++ att +attTName att = pp $ "Att_" ++ att + + +defAttRec recPref ppNt atts noGroup = + let recName = ppName [recPref, ppNt] + fields = ppCommas (map (\(a,t) -> ppName [pp a, recName ] >|< " ::" >|< ppShow t) (groupAtts atts noGroup)) + in + "data " >|< recName >|< " = " >|< recName >|< " { " >|< fields >|< " }" + +groupAtts atts noGroup = (Map.toAscList . Map.difference atts) noGroup + +-- it defines selectors with the form: +-- l1_nt_prod(x, _, .., _) = x +-- ln_nt_prod(_, .., _, x) = x +defLocalAtts prodName total actual (l:ls) = ppName [pp l, prodName] >|< + ppListSep "(" ")" "," (replicate (actual-1) "_" ++ "x" : replicate (total-actual) "_") >|< + pp " = x" >-< + defLocalAtts prodName total (actual+1) ls +defLocalAtts _ _ _ [] = empty + {-# LINE 103 "src-generated/AG2AspectAG.hs" #-} {-# LINE 397 "src-ag/AG2AspectAG.ag" #-} - -ntsList att ppNtL = "nts_" ++ att ++ " = " >|< ppListSep "" "" " .*. " ((map fst ppNtL) ++ [pp "hNil"]) - -filterNts att = filter ( Map.member (identifier att) . snd ) + +ntsList att ppNtL = "nts_" ++ att ++ " = " >|< ppListSep "" "" " .*. " ((map fst ppNtL) ++ [pp "hNil"]) + +filterNts att = filter ( Map.member (identifier att) . snd ) {-# LINE 110 "src-generated/AG2AspectAG.hs" #-} {-# LINE 455 "src-ag/AG2AspectAG.ag" #-} - -data PPRule = PPRule Identifier Identifier Bool ([(Identifier,Type)] -> [Identifier] -> PP_Doc) - -ppRule (field,attr) owrt def = PPRule field attr owrt def -ruleField (PPRule field _ _ _ ) = field -ruleAttr (PPRule _ attr _ _ ) = attr -ruleOwrt (PPRule _ _ owrt _ ) = owrt -ruleDef (PPRule _ _ _ def) = def - + +data PPRule = PPRule Identifier Identifier Bool ([(Identifier,Type)] -> [Identifier] -> PP_Doc) + +ppRule (field,attr) owrt def = PPRule field attr owrt def +ruleField (PPRule field _ _ _ ) = field +ruleAttr (PPRule _ attr _ _ ) = attr +ruleOwrt (PPRule _ _ owrt _ ) = owrt +ruleDef (PPRule _ _ _ def) = def + {-# LINE 122 "src-generated/AG2AspectAG.hs" #-} {-# LINE 494 "src-ag/AG2AspectAG.ag" #-} - - -defInhGRule ppNt prodName newNT newProd ch rules inhNoGroup synNoGroup chids locals = - let ppAtt = ppName [pp "inh", prodName] - ppR = ppAtt >|< pp " = inhdefM att_inh nts_group $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 (foldr (>-<) (pp "emptyRecord") (map (chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals) chids)) - in if (newNT || (not newNT && newProd)) - then (ppR, [ ppAtt ]) - else (empty, []) - -chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals (idCh,tp) = - let chName = ppName [pp "ch", pp idCh, prodName] - ppTp = ppShow tp - chRules = ppCommas $ mapGRuleDefs (== idCh) rules inhNoGroup synNoGroup chids locals - in if (isNonterminal tp) - then chName >|< ".=." >-< - indent 1 "InhG_" >|< ppShow tp >|< pp " {" >-< - indent 2 chRules >-< - indent 1 "} .*. " - else empty - - -defSynGRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = - let ppAtt = ppName [pp "syn", ppNt, pp prod] - ppTAtt = "SynG_" >|< ppNt - ppR = ppAtt >|< pp " = syndefM att_syn $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 ppTAtt >|< pp " {" >-< - indent 7 (ppCommas $ mapGRuleDefs ((== "lhs") . show) rules inhNoGroup synNoGroup chids locals) >-< - indent 6 "}" - in if (newNT || (not newNT && newProd)) - then (ppR, [ ppAtt ]) - else (empty, []) - -defLocRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = - let ppAtt = ppName [pp "loc", ppNt, pp prod] - ppTAtt = ppName [pp "Loc", ppNt, pp prod] - ppR = ppAtt >|< pp " = locdefM att_loc $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 (ppListSep "(" ")" "," $ mapLRuleDefs rules inhNoGroup synNoGroup chids locals) - in (ppR, [ ppAtt ]) - -defInstRules ppNt prod newNT newProd ch rules chids locals - = let ppAsp = ppName [pp "inst", ppNt, pp prod] - instRules = filter ((=="inst") . show . ruleField) rules - ppAtt att = ppListSep "`ext` " "" "_" [pp "inst_ch", pp att, ppNt, pp prod] - in ( ppAsp >|< pp " = emptyRule " >|< (map (ppAtt . ruleAttr) instRules) >-< - (vlist $ map (defInstRule ppNt prod ch chids locals) instRules) - , [ ppAsp ]) - - -defInstRule ppNt prod ch chids locals rule = - let ppAtt = ppName [pp "ch", pp (ruleAttr rule), ppNt, pp prod] - in pp "inst_" >|< ppAtt >|< pp " = instdefM " >|< ppAtt >|< pp " $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 ((ruleDef rule) chids locals) - - -defSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals - = let synRules = filter ( (=="lhs") . show . ruleField) rules - ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules - (ppR, ppRA) = unzip $ map (defSynRule True ppNt prod newNT newProd newAtts ch chids locals) ngRules - in (vlist ppR, concat ppRA ) - -modSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals - = let synRules = filter ( (=="lhs") . show . ruleField) rules - ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules - (ppR, ppRA) = unzip $ map (defSynRule False ppNt prod newNT newProd newAtts ch chids locals) ngRules - in (vlist ppR, concat ppRA ) - -defSynRule new ppNt prod newNT newProd newAtts ch chids locals rule = - let att = ruleAttr rule - newAtt = Map.member att newAtts - owrt = ruleOwrt rule - ppAtt = ppName [pp att, pp (if new then "syn" else "synM"), ppNt, pp prod] - ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName (show att) >|< pp " $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 ((ruleDef rule) chids locals) - in - if new - then if (not owrt && (newNT || (not newNT && newProd) || newAtt)) - then (ppR "syndefM", [ ppAtt ]) - else (empty, []) - else if owrt - then (ppR "synmodM", [ ppAtt ]) - else (empty, []) - - - -defInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals - = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules - (ppR, ppRA) = unzip $ map (defInhRule True ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup - in (vlist ppR, concat ppRA) - -modInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals - = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules - (ppR, ppRA) = unzip $ map (defInhRule False ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup - in (vlist ppR, concat ppRA) - - -defInhRule new ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals att = - let ppAtt = ppName [pp att, pp (if new then "inh" else "inhM"),prodName] - newAtt = Map.member (identifier att) newAtts - chRMaybe = map (chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals) chids - chR = [ x | (Just x) <- chRMaybe ] - ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName att >|< " nts_" >|< att >|< " $" >-< - indent 4 "do " >-< - indent 5 "loc <- at loc" >-< - indent 5 "lhs <- at lhs" >-< - indent 5 ch >-< - indent 5 "return $" >-< - indent 6 (foldr (>-<) (pp "emptyRecord") chR) - in - if new - then if (newNT || (not newNT && newProd) || newAtt) - then (ppR "inhdefM", [ ppAtt ]) - else (empty, []) - else if (not . null) chR - then (ppR "inhmodM", [ ppAtt ]) - else (empty, []) - - -chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals (idCh,tp) = - let chName = ppName [pp "ch", pp idCh, prodName] - ppTp = ppShow tp - chRule = inhRuleDef new (== idCh) (== att) rules inhNoGroup synNoGroup chids locals -- it's supposed to be only one - in if (isNonterminal tp && (not . null) chRule) - then Just $ chName >|< ".=. (" >|< chRule >|< ") .*. " - else Nothing - - -mapLRuleDefs rules inhNoGroup synNoGroup chids locals - = map appSnd $ sortBy cmpField $ filter ((== "loc") . show . ruleField) rules - where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) - appSnd rule = (ruleDef rule) chids locals - - -mapGRuleDefs filt rules inhNoGroup synNoGroup chids locals - = map appSnd $ sortBy cmpField $ filter (not . (flip elem inhNoGroup) . getName . ruleAttr) - $ filter (not . (flip elem synNoGroup) . getName . ruleAttr) - $ filter ( filt . ruleField) rules - where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) - appSnd rule = (ruleDef rule) chids locals - -inhRuleDef new filt1 filt2 rules inhNoGroup synNoGroup chids locals - = map appSnd $ sortBy cmpField $ filter ( (== not new) . ruleOwrt) - $ filter ((flip elem inhNoGroup) . getName . ruleAttr) - $ filter ( filt2 . getName . ruleAttr) - $ filter ( filt1 . ruleField) rules - where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) - appSnd rule = (ruleDef rule) chids locals - -defRule ppNt (field,att) noGroup rhs = \chids locals -> - let ppAtt = if (elem (getName att) noGroup) - then empty - else case (show field) of - "lhs" -> att >|< "_" >|< pp "SynG" >|< pp "_" >|< ppNt >|< " = " - "loc" -> empty - "inst" -> empty - otherwise -> att >|< "_" >|< pp "InhG" >|< pp "_" >|< - (maybe (error $ "lhs field " ++ show field ++" is not a child") - ppShow (lookup field chids)) - >|< " = " - in ppAtt >|< (rhs noGroup field chids locals) - - -rhsRule ppNt ppProd tks noGroup field chids locals = vlist . lines2PP . (map (token2PP ppNt ppProd field chids locals noGroup )) $ tks - - -lines2PP [] = [] -lines2PP xs = map line2PP . shiftLeft . getLines $ xs - - -token2PP ppNt ppProd field chids locals noGroup tk - = case tk of - AGLocal var pos _ -> (pos, if (elem var locals) - then (ppListSep "(" "" "_" [pp var, ppNt, ppProd]) >|< pp " (loc # att_loc)) " - else pp var) - AGField field attr pos _ -> let ppChT = maybe (error $ "rhs field " ++ show field ++ " is not a child") ppShow (lookup field chids) - ppAtt = case (show field) of - "lhs" -> attName "inh" - "loc" -> attName "loc" - otherwise -> attName "syn" - ppSubAtt = case (show field) of - "lhs" -> ppName [pp (getName attr), pp "InhG", ppNt] - "loc" -> ppName [pp (getName attr), ppNt, ppProd] - otherwise -> ppName [pp (getName attr), pp "SynG", ppChT] - in (pos, if ((elem (getName attr) noGroup) && ((show field) /= "loc")) - then pp "(" >|< pp (getName field) >|< " # " >|< attName (getName attr) >|< pp ")" - else pp "(" >|< ppSubAtt >|< " (" >|< pp (getName field) >|< " # " >|< ppAtt >|< ")) ") - HsToken value pos -> (pos, pp value) - CharToken value pos -> (pos, pp (show value)) - StrToken value pos -> (pos, pp (show value)) - Err mesg pos -> (pos, pp $ " ***" ++ mesg ++ "*** ") - -line2PP ts = let f (p,t) r = let ct = column p - in \c -> pp (spaces (ct-c)) >|< t >|< r (length (show t) +ct) - spaces x | x < 0 = "" - | otherwise = replicate x ' ' - in foldr f (pp . const "") ts 1 - + + +defInhGRule ppNt prodName newNT newProd ch rules inhNoGroup synNoGroup chids locals = + let ppAtt = ppName [pp "inh", prodName] + ppR = ppAtt >|< pp " = inhdefM att_inh nts_group $" >-< + indent 4 "do " >-< + indent 5 "loc <- at loc" >-< + indent 5 "lhs <- at lhs" >-< + indent 5 ch >-< + indent 5 "return $" >-< + indent 6 (foldr (>-<) (pp "emptyRecord") (map (chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals) chids)) + in if (newNT || (not newNT && newProd)) + then (ppR, [ ppAtt ]) + else (empty, []) + +chGRule ppNt prodName rules inhNoGroup synNoGroup chids locals (idCh,tp) = + let chName = ppName [pp "ch", pp idCh, prodName] + ppTp = ppShow tp + chRules = ppCommas $ mapGRuleDefs (== idCh) rules inhNoGroup synNoGroup chids locals + in if (isNonterminal tp) + then chName >|< ".=." >-< + indent 1 "InhG_" >|< ppShow tp >|< pp " {" >-< + indent 2 chRules >-< + indent 1 "} .*. " + else empty + + +defSynGRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = + let ppAtt = ppName [pp "syn", ppNt, pp prod] + ppTAtt = "SynG_" >|< ppNt + ppR = ppAtt >|< pp " = syndefM att_syn $" >-< + indent 4 "do " >-< + indent 5 "loc <- at loc" >-< + indent 5 "lhs <- at lhs" >-< + indent 5 ch >-< + indent 5 "return $" >-< + indent 6 ppTAtt >|< pp " {" >-< + indent 7 (ppCommas $ mapGRuleDefs ((== "lhs") . show) rules inhNoGroup synNoGroup chids locals) >-< + indent 6 "}" + in if (newNT || (not newNT && newProd)) + then (ppR, [ ppAtt ]) + else (empty, []) + +defLocRule ppNt prod newNT newProd ch rules inhNoGroup synNoGroup chids locals = + let ppAtt = ppName [pp "loc", ppNt, pp prod] + ppTAtt = ppName [pp "Loc", ppNt, pp prod] + ppR = ppAtt >|< pp " = locdefM att_loc $" >-< + indent 4 "do " >-< + indent 5 "loc <- at loc" >-< + indent 5 "lhs <- at lhs" >-< + indent 5 ch >-< + indent 5 "return $" >-< + indent 6 (ppListSep "(" ")" "," $ mapLRuleDefs rules inhNoGroup synNoGroup chids locals) + in (ppR, [ ppAtt ]) + +defInstRules ppNt prod newNT newProd ch rules chids locals + = let ppAsp = ppName [pp "inst", ppNt, pp prod] + instRules = filter ((=="inst") . show . ruleField) rules + ppAtt att = ppListSep "`ext` " "" "_" [pp "inst_ch", pp att, ppNt, pp prod] + in ( ppAsp >|< pp " = emptyRule " >|< (map (ppAtt . ruleAttr) instRules) >-< + (vlist $ map (defInstRule ppNt prod ch chids locals) instRules) + , [ ppAsp ]) + + +defInstRule ppNt prod ch chids locals rule = + let ppAtt = ppName [pp "ch", pp (ruleAttr rule), ppNt, pp prod] + in pp "inst_" >|< ppAtt >|< pp " = instdefM " >|< ppAtt >|< pp " $" >-< + indent 4 "do " >-< + indent 5 "loc <- at loc" >-< + indent 5 "lhs <- at lhs" >-< + indent 5 ch >-< + indent 5 "return $" >-< + indent 6 ((ruleDef rule) chids locals) + + +defSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals + = let synRules = filter ( (=="lhs") . show . ruleField) rules + ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules + (ppR, ppRA) = unzip $ map (defSynRule True ppNt prod newNT newProd newAtts ch chids locals) ngRules + in (vlist ppR, concat ppRA ) + +modSynRules ppNt prod newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals + = let synRules = filter ( (=="lhs") . show . ruleField) rules + ngRules = filter ((flip elem synNoGroup) . getName . ruleAttr) synRules + (ppR, ppRA) = unzip $ map (defSynRule False ppNt prod newNT newProd newAtts ch chids locals) ngRules + in (vlist ppR, concat ppRA ) + +defSynRule new ppNt prod newNT newProd newAtts ch chids locals rule = + let att = ruleAttr rule + newAtt = Map.member att newAtts + owrt = ruleOwrt rule + ppAtt = ppName [pp att, pp (if new then "syn" else "synM"), ppNt, pp prod] + ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName (show att) >|< pp " $" >-< + indent 4 "do " >-< + indent 5 "loc <- at loc" >-< + indent 5 "lhs <- at lhs" >-< + indent 5 ch >-< + indent 5 "return $" >-< + indent 6 ((ruleDef rule) chids locals) + in + if new + then if (not owrt && (newNT || (not newNT && newProd) || newAtt)) + then (ppR "syndefM", [ ppAtt ]) + else (empty, []) + else if owrt + then (ppR "synmodM", [ ppAtt ]) + else (empty, []) + + + +defInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals + = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules + (ppR, ppRA) = unzip $ map (defInhRule True ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup + in (vlist ppR, concat ppRA) + +modInhRules ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals + = let ngRules = filter ((flip elem inhNoGroup) . getName . ruleAttr) rules + (ppR, ppRA) = unzip $ map (defInhRule False ppNt prodName newNT newProd newAtts ch ngRules inhNoGroup synNoGroup chids locals) inhNoGroup + in (vlist ppR, concat ppRA) + + +defInhRule new ppNt prodName newNT newProd newAtts ch rules inhNoGroup synNoGroup chids locals att = + let ppAtt = ppName [pp att, pp (if new then "inh" else "inhM"),prodName] + newAtt = Map.member (identifier att) newAtts + chRMaybe = map (chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals) chids + chR = [ x | (Just x) <- chRMaybe ] + ppR def = ppAtt >|< pp (" = " ++ def ++ " ") >|< attName att >|< " nts_" >|< att >|< " $" >-< + indent 4 "do " >-< + indent 5 "loc <- at loc" >-< + indent 5 "lhs <- at lhs" >-< + indent 5 ch >-< + indent 5 "return $" >-< + indent 6 (foldr (>-<) (pp "emptyRecord") chR) + in + if new + then if (newNT || (not newNT && newProd) || newAtt) + then (ppR "inhdefM", [ ppAtt ]) + else (empty, []) + else if (not . null) chR + then (ppR "inhmodM", [ ppAtt ]) + else (empty, []) + + +chRule new ppNt prodName att rules inhNoGroup synNoGroup chids locals (idCh,tp) = + let chName = ppName [pp "ch", pp idCh, prodName] + ppTp = ppShow tp + chRule = inhRuleDef new (== idCh) (== att) rules inhNoGroup synNoGroup chids locals -- it's supposed to be only one + in if (isNonterminal tp && (not . null) chRule) + then Just $ chName >|< ".=. (" >|< chRule >|< ") .*. " + else Nothing + + +mapLRuleDefs rules inhNoGroup synNoGroup chids locals + = map appSnd $ sortBy cmpField $ filter ((== "loc") . show . ruleField) rules + where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) + appSnd rule = (ruleDef rule) chids locals + + +mapGRuleDefs filt rules inhNoGroup synNoGroup chids locals + = map appSnd $ sortBy cmpField $ filter (not . (flip elem inhNoGroup) . getName . ruleAttr) + $ filter (not . (flip elem synNoGroup) . getName . ruleAttr) + $ filter ( filt . ruleField) rules + where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) + appSnd rule = (ruleDef rule) chids locals + +inhRuleDef new filt1 filt2 rules inhNoGroup synNoGroup chids locals + = map appSnd $ sortBy cmpField $ filter ( (== not new) . ruleOwrt) + $ filter ((flip elem inhNoGroup) . getName . ruleAttr) + $ filter ( filt2 . getName . ruleAttr) + $ filter ( filt1 . ruleField) rules + where cmpField r1 r2 = compare (ruleField r1) (ruleField r2) + appSnd rule = (ruleDef rule) chids locals + +defRule ppNt (field,att) noGroup rhs = \chids locals -> + let ppAtt = if (elem (getName att) noGroup) + then empty + else case (show field) of + "lhs" -> att >|< "_" >|< pp "SynG" >|< pp "_" >|< ppNt >|< " = " + "loc" -> empty + "inst" -> empty + otherwise -> att >|< "_" >|< pp "InhG" >|< pp "_" >|< + (maybe (error $ "lhs field " ++ show field ++" is not a child") + ppShow (lookup field chids)) + >|< " = " + in ppAtt >|< (rhs noGroup field chids locals) + + +rhsRule ppNt ppProd tks noGroup field chids locals = vlist . lines2PP . (map (token2PP ppNt ppProd field chids locals noGroup )) $ tks + + +lines2PP [] = [] +lines2PP xs = map line2PP . shiftLeft . getLines $ xs + + +token2PP ppNt ppProd field chids locals noGroup tk + = case tk of + AGLocal var pos _ -> (pos, if (elem var locals) + then (ppListSep "(" "" "_" [pp var, ppNt, ppProd]) >|< pp " (loc # att_loc)) " + else pp var) + AGField field attr pos _ -> let ppChT = maybe (error $ "rhs field " ++ show field ++ " is not a child") ppShow (lookup field chids) + ppAtt = case (show field) of + "lhs" -> attName "inh" + "loc" -> attName "loc" + otherwise -> attName "syn" + ppSubAtt = case (show field) of + "lhs" -> ppName [pp (getName attr), pp "InhG", ppNt] + "loc" -> ppName [pp (getName attr), ppNt, ppProd] + otherwise -> ppName [pp (getName attr), pp "SynG", ppChT] + in (pos, if ((elem (getName attr) noGroup) && ((show field) /= "loc")) + then pp "(" >|< pp (getName field) >|< " # " >|< attName (getName attr) >|< pp ")" + else pp "(" >|< ppSubAtt >|< " (" >|< pp (getName field) >|< " # " >|< ppAtt >|< ")) ") + HsToken value pos -> (pos, pp value) + CharToken value pos -> (pos, pp (show value)) + StrToken value pos -> (pos, pp (show value)) + Err mesg pos -> (pos, pp $ " ***" ++ mesg ++ "*** ") + +line2PP ts = let f (p,t) r = let ct = column p + in \c -> pp (spaces (ct-c)) >|< t >|< r (length (show t) +ct) + spaces x | x < 0 = "" + | otherwise = replicate x ' ' + in foldr f (pp . const "") ts 1 + {-# LINE 347 "src-generated/AG2AspectAG.hs" #-} {-# LINE 721 "src-ag/AG2AspectAG.ag" #-} - -ppMacro (Macro con children) = "( atts_" >|< show con >|< ", " >|< ppListSep "" "" " <.> " ppChildren >|<")" - where ppChildren = map ppChild children - ppChild (RuleChild ch n) = chName ch >|< " ==> " >|< ppMacro n - ppChild (ChildChild ch n) = chName ch >|< " --> " >|< n - ppChild (ValueChild ch n) = chName ch >|< " ~~> " >|< n - chName ch = ppName [pp "ch", pp ch, pp con] + +ppMacro (Macro con children) = "( atts_" >|< show con >|< ", " >|< ppListSep "" "" " <.> " ppChildren >|<")" + where ppChildren = map ppChild children + ppChild (RuleChild ch n) = chName ch >|< " ==> " >|< ppMacro n + ppChild (ChildChild ch n) = chName ch >|< " --> " >|< n + ppChild (ValueChild ch n) = chName ch >|< " ~~> " >|< n + chName ch = ppName [pp "ch", pp ch, pp con] {-# LINE 357 "src-generated/AG2AspectAG.hs" #-} {-# LINE 754 "src-ag/AG2AspectAG.ag" #-} - -ppNoGroupAtts syn noGroup = let synatts = Map.keys $ Map.filterWithKey (\att _ -> elem (getName att) noGroup) syn - in map (flip (>|<) "_inh") noGroup ++ map (flip (>|<) "_syn") synatts - -ruleName att prodName = ppName [att,prodName] - -elemNT a b = False + +ppNoGroupAtts syn noGroup = let synatts = Map.keys $ Map.filterWithKey (\att _ -> elem (getName att) noGroup) syn + in map (flip (>|<) "_inh") noGroup ++ map (flip (>|<) "_syn") synatts + +ruleName att prodName = ppName [att,prodName] + +elemNT a b = False {-# LINE 367 "src-generated/AG2AspectAG.hs" #-} {-# LINE 797 "src-ag/AG2AspectAG.ag" #-} - -attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts + +attTypes atts = map (\(a,t) -> "(HCons (LVPair (Proxy Att_" >|< a >|< ") " >|< ppShow t >|< ") ") $ Map.toAscList atts {-# LINE 372 "src-generated/AG2AspectAG.hs" #-} {-# LINE 851 "src-ag/AG2AspectAG.ag" #-} - -attVars atts = map (\(a,_) -> "_" >|< a >|< " ") $ Map.toAscList atts -attFields atts noGroup ppNt = - let ng = map (\(a,_) -> attName (getName a) >|< " .=. _" >|< a >|< " .*. ") $ Map.toAscList noGroup - g = ppCommas $ map (\(a,_) -> ppName [pp a, pp "InhG",ppNt] >|< "= _" >|< a) $ Map.toAscList $ Map.difference atts noGroup - in "(" >|< ng >|< "att_inh .=. " >|< ppName [pp "InhG", ppNt] >|< " { " >|< g >|< " } .*. emptyRecord)" + +attVars atts = map (\(a,_) -> "_" >|< a >|< " ") $ Map.toAscList atts +attFields atts noGroup ppNt = + let ng = map (\(a,_) -> attName (getName a) >|< " .=. _" >|< a >|< " .*. ") $ Map.toAscList noGroup + g = ppCommas $ map (\(a,_) -> ppName [pp a, pp "InhG",ppNt] >|< "= _" >|< a) $ Map.toAscList $ Map.difference atts noGroup + in "(" >|< ng >|< "att_inh .=. " >|< ppName [pp "InhG", ppNt] >|< " { " >|< g >|< " } .*. emptyRecord)" {-# LINE 381 "src-generated/AG2AspectAG.hs" #-} -- Child ------------------------------------------------------- -- wrapper diff --git a/src-generated/AbstractSyntax.hs b/src-generated/AbstractSyntax.hs --- a/src-generated/AbstractSyntax.hs +++ b/src-generated/AbstractSyntax.hs @@ -3,15 +3,15 @@ -- UUAGC 0.9.53 (src-ag/AbstractSyntax.ag) module AbstractSyntax where {-# LINE 2 "src-ag/AbstractSyntax.ag" #-} - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import Macro --marcos -import CommonTypes -import ErrorMessages + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import Macro --marcos +import CommonTypes +import ErrorMessages {-# LINE 16 "src-generated/AbstractSyntax.hs" #-} -- Child ------------------------------------------------------- {- diff --git a/src-generated/AbstractSyntaxDump.hs b/src-generated/AbstractSyntaxDump.hs --- a/src-generated/AbstractSyntaxDump.hs +++ b/src-generated/AbstractSyntaxDump.hs @@ -3,40 +3,40 @@ module AbstractSyntaxDump where {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 10 "src-generated/AbstractSyntaxDump.hs" #-} {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 17 "src-generated/AbstractSyntaxDump.hs" #-} {-# LINE 2 "src-ag/AbstractSyntax.ag" #-} - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import Macro --marcos -import CommonTypes -import ErrorMessages + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import Macro --marcos +import CommonTypes +import ErrorMessages {-# LINE 29 "src-generated/AbstractSyntaxDump.hs" #-} {-# LINE 6 "src-ag/AbstractSyntaxDump.ag" #-} - -import Data.List -import qualified Data.Map as Map - -import Pretty -import PPUtil - -import AbstractSyntax -import TokenDef + +import Data.List +import qualified Data.Map as Map + +import Pretty +import PPUtil + +import AbstractSyntax +import TokenDef {-# LINE 41 "src-generated/AbstractSyntaxDump.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity diff --git a/src-generated/Code.hs b/src-generated/Code.hs --- a/src-generated/Code.hs +++ b/src-generated/Code.hs @@ -3,30 +3,30 @@ -- UUAGC 0.9.53 (src-ag/Code.ag) module Code where {-# LINE 2 "src-ag/Code.ag" #-} - -import Patterns -import Data.Set(Set) -import qualified Data.Set as Set -import Data.Map(Map) -import qualified Data.Map as Map + +import Patterns +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Map(Map) +import qualified Data.Map as Map {-# LINE 13 "src-generated/Code.hs" #-} {-# LINE 146 "src-ag/Code.ag" #-} - --- Unboxed tuples --- unbox Whether unboxed tuples are wanted or not --- inh The inherited attributes. --- If there are none, no unboxing can take place, --- because in that case the semantic function (a top-level identifier) would have an unboxed type. --- Of course we can't have an unboxed 1-tuple -mkTupleExpr :: Bool -> Bool -> Exprs -> Expr -mkTupleExpr unbox' noInh exprs | not unbox' || noInh || length exprs == 1 = TupleExpr exprs - | otherwise = UnboxedTupleExpr exprs -mkTupleType :: Bool -> Bool -> Types -> Type -mkTupleType unbox' noInh tps | not unbox' || noInh || length tps == 1 = TupleType tps - | otherwise = UnboxedTupleType tps -mkTupleLhs :: Bool -> Bool -> [String] -> Lhs -mkTupleLhs unbox' noInh comps | not unbox' || noInh || length comps == 1 = TupleLhs comps - | otherwise = UnboxedTupleLhs comps + +-- Unboxed tuples +-- unbox Whether unboxed tuples are wanted or not +-- inh The inherited attributes. +-- If there are none, no unboxing can take place, +-- because in that case the semantic function (a top-level identifier) would have an unboxed type. +-- Of course we can't have an unboxed 1-tuple +mkTupleExpr :: Bool -> Bool -> Exprs -> Expr +mkTupleExpr unbox' noInh exprs | not unbox' || noInh || length exprs == 1 = TupleExpr exprs + | otherwise = UnboxedTupleExpr exprs +mkTupleType :: Bool -> Bool -> Types -> Type +mkTupleType unbox' noInh tps | not unbox' || noInh || length tps == 1 = TupleType tps + | otherwise = UnboxedTupleType tps +mkTupleLhs :: Bool -> Bool -> [String] -> Lhs +mkTupleLhs unbox' noInh comps | not unbox' || noInh || length comps == 1 = TupleLhs comps + | otherwise = UnboxedTupleLhs comps {-# LINE 31 "src-generated/Code.hs" #-} -- CaseAlt ----------------------------------------------------- {- diff --git a/src-generated/CodeSyntax.hs b/src-generated/CodeSyntax.hs --- a/src-generated/CodeSyntax.hs +++ b/src-generated/CodeSyntax.hs @@ -3,11 +3,11 @@ -- UUAGC 0.9.53 (src-ag/CodeSyntax.ag) module CodeSyntax where {-# LINE 2 "src-ag/CodeSyntax.ag" #-} - -import Patterns -import CommonTypes -import Data.Map(Map) -import Data.Set(Set) + +import Patterns +import CommonTypes +import Data.Map(Map) +import Data.Set(Set) {-# LINE 12 "src-generated/CodeSyntax.hs" #-} -- CGrammar ---------------------------------------------------- {- diff --git a/src-generated/CodeSyntaxDump.hs b/src-generated/CodeSyntaxDump.hs --- a/src-generated/CodeSyntaxDump.hs +++ b/src-generated/CodeSyntaxDump.hs @@ -3,59 +3,59 @@ module CodeSyntaxDump where {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 11 "src-generated/CodeSyntaxDump.hs" #-} {-# LINE 2 "src-ag/CodeSyntax.ag" #-} - -import Patterns -import CommonTypes -import Data.Map(Map) -import Data.Set(Set) + +import Patterns +import CommonTypes +import Data.Map(Map) +import Data.Set(Set) {-# LINE 19 "src-generated/CodeSyntaxDump.hs" #-} {-# LINE 5 "src-ag/CodeSyntaxDump.ag" #-} - -import Data.List -import qualified Data.Map as Map - -import Pretty -import PPUtil - -import CodeSyntax + +import Data.List +import qualified Data.Map as Map + +import Pretty +import PPUtil + +import CodeSyntax {-# LINE 30 "src-generated/CodeSyntaxDump.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 15 "src-ag/CodeSyntaxDump.ag" #-} - -ppChild :: (Identifier,Type,ChildKind) -> PP_Doc -ppChild (nm,tp,_) - = pp nm >#< "::" >#< pp (show tp) - -ppVertexMap :: Map Int (Identifier,Identifier,Maybe Type) -> PP_Doc -ppVertexMap m - = ppVList [ ppF (show k) $ ppAttr v | (k,v) <- Map.toList m ] - -ppAttr :: (Identifier,Identifier,Maybe Type) -> PP_Doc -ppAttr (fld,nm,mTp) - = pp fld >|< "." >|< pp nm >#< - case mTp of - Just tp -> pp "::" >#< show tp - Nothing -> empty - -ppBool :: Bool -> PP_Doc -ppBool True = pp "T" -ppBool False = pp "F" - -ppMaybeShow :: Show a => Maybe a -> PP_Doc -ppMaybeShow (Just x) = pp (show x) -ppMaybeShow Nothing = pp "_" - -ppStrings :: [String] -> PP_Doc -ppStrings = vlist + +ppChild :: (Identifier,Type,ChildKind) -> PP_Doc +ppChild (nm,tp,_) + = pp nm >#< "::" >#< pp (show tp) + +ppVertexMap :: Map Int (Identifier,Identifier,Maybe Type) -> PP_Doc +ppVertexMap m + = ppVList [ ppF (show k) $ ppAttr v | (k,v) <- Map.toList m ] + +ppAttr :: (Identifier,Identifier,Maybe Type) -> PP_Doc +ppAttr (fld,nm,mTp) + = pp fld >|< "." >|< pp nm >#< + case mTp of + Just tp -> pp "::" >#< show tp + Nothing -> empty + +ppBool :: Bool -> PP_Doc +ppBool True = pp "T" +ppBool False = pp "F" + +ppMaybeShow :: Show a => Maybe a -> PP_Doc +ppMaybeShow (Just x) = pp (show x) +ppMaybeShow Nothing = pp "_" + +ppStrings :: [String] -> PP_Doc +ppStrings = vlist {-# LINE 60 "src-generated/CodeSyntaxDump.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper diff --git a/src-generated/ConcreteSyntax.hs b/src-generated/ConcreteSyntax.hs --- a/src-generated/ConcreteSyntax.hs +++ b/src-generated/ConcreteSyntax.hs @@ -3,12 +3,12 @@ -- UUAGC 0.9.53 (src-ag/ConcreteSyntax.ag) module ConcreteSyntax where {-# LINE 2 "src-ag/ConcreteSyntax.ag" #-} - -import UU.Scanner.Position (Pos) -import Patterns (Pattern) -import Expression (Expression) -import CommonTypes -import Macro --marcos + +import UU.Scanner.Position (Pos) +import Patterns (Pattern) +import Expression (Expression) +import CommonTypes +import Macro --marcos {-# LINE 13 "src-generated/ConcreteSyntax.hs" #-} -- AG ---------------------------------------------------------- {- diff --git a/src-generated/DeclBlocks.hs b/src-generated/DeclBlocks.hs --- a/src-generated/DeclBlocks.hs +++ b/src-generated/DeclBlocks.hs @@ -3,8 +3,8 @@ -- UUAGC 0.9.53 (src-ag/DeclBlocks.ag) module DeclBlocks where {-# LINE 2 "src-ag/DeclBlocks.ag" #-} - -import Code (Decl,Expr) + +import Code (Decl,Expr) {-# LINE 9 "src-generated/DeclBlocks.hs" #-} -- DeclBlocks -------------------------------------------------- {- diff --git a/src-generated/DefaultRules.hs b/src-generated/DefaultRules.hs --- a/src-generated/DefaultRules.hs +++ b/src-generated/DefaultRules.hs @@ -4,460 +4,460 @@ module DefaultRules where {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 12 "src-generated/DefaultRules.hs" #-} {-# LINE 2 "src-ag/AbstractSyntax.ag" #-} - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import Macro --marcos -import CommonTypes -import ErrorMessages + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import Macro --marcos +import CommonTypes +import ErrorMessages {-# LINE 24 "src-generated/DefaultRules.hs" #-} {-# LINE 15 "src-ag/DefaultRules.ag" #-} - -import qualified Data.List -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq,(><)) -import UU.Scanner.Position(noPos) -import Pretty -import Data.Maybe -import HsToken -import HsTokenScanner -import Data.List(intersperse) -import Data.Char - -import AbstractSyntax -import ErrorMessages - -import Options + +import qualified Data.List +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Sequence as Seq +import Data.Sequence(Seq,(><)) +import UU.Scanner.Position(noPos) +import Pretty +import Data.Maybe +import HsToken +import HsTokenScanner +import Data.List(intersperse) +import Data.Char + +import AbstractSyntax +import ErrorMessages + +import Options {-# LINE 46 "src-generated/DefaultRules.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 80 "src-ag/DefaultRules.ag" #-} - -fieldName n = '@' : getName n - -locName n = "@loc." ++ getName n - -attrName fld attr - | fld == _LOC = locName attr - | fld == _FIELD = fieldName attr - | otherwise = '@' : getName fld ++ "." ++ getName attr - -_ACHILD = Ident "(" noPos -- hack - -mkLocVar = AGField _LOC - -isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool -isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor - -buildConExpr ocaml clean conmap typeSyns rename nt con1 fs' - | nt `elem` map fst typeSyns = if ocaml then synonymMl - else if clean then synonymClean - else synonymHs - | otherwise = normalExpr - where fs = map fst fs' - con = getName con1 - tup = " " ++ buildTuple fs - args = " " ++ unwords fs - normalExpr = if clean && isRecordConstructor nt conmap - then "{" ++ con ++ "|" ++ - unwords (intersperse "," $ map (\(new, old) -> getName old ++ " = " ++ new) fs') - ++ "}" - else conname' ++ args - - conname' | rename = getName nt ++ "_" ++ getName con1 - | otherwise = getName con1 - - synonymHs | con == "Tuple" = buildTuple fs - | con == "Cons" = "(:)" ++ args - | con == "Nil" = case lookup nt typeSyns of - Just (Map _ _) -> "Data.Map.empty" - Just (IntMap _) -> "Data.IntMap.empty" - Just (OrdSet _) -> "Data.Set.empty" - Just IntSet -> "Data.IntSet.empty" - _ -> "[]" - | con == "Just" = "Just" ++ args - | con == "Nothing" = "Nothing" - | con == "Entry" = ( case lookup nt typeSyns of - Just (Map _ _) -> "Data.Map.insert" - Just (IntMap _) -> "Data.IntMap.insert" - Just (OrdSet _) -> "Data.Set.insert" - Just IntSet -> "Data.IntSet.insert" ) ++ args - | otherwise = normalExpr - - synonymMl | con == "Tuple" = buildTuple fs - | con == "Cons" = "(::)" ++ tup - | con == "Nil" = case lookup nt typeSyns of - Just (Map _ _) -> prefixMod nt "empty" - Just (IntMap _) -> prefixMod nt "empty" - Just (OrdSet _) -> prefixMod nt "empty" - Just IntSet -> prefixMod nt "empty" - _ -> "[]" - | con == "Just" = "Some" ++ tup - | con == "Nothing" = "None" - | con == "Entry" = ( case lookup nt typeSyns of - Just (Map _ _) -> prefixMod nt "add" - Just (IntMap _) -> prefixMod nt "add" - Just (OrdSet _) -> prefixMod nt "add" - Just IntSet -> prefixMod nt "add" ) ++ args - | otherwise = normalExpr - - synonymClean | con == "Tuple" = buildTuple fs - | con == "Cons" = "(\\x xs -> [x:xs])" ++ args - | con == "Nil" = case lookup nt typeSyns of - Just (Map _ _) -> "Data.Map.empty" - Just (IntMap _) -> "Data.IntMap.empty" - Just (OrdSet _) -> "Data.Set.empty" - Just IntSet -> "Data.IntSet.empty" - _ -> "[]" - | con == "Just" = "Just" ++ args - | con == "Nothing" = "Nothing" - | con == "Entry" = ( case lookup nt typeSyns of - Just (Map _ _) -> "Data.Map.insert" - Just (IntMap _) -> "Data.IntMap.insert" - Just (OrdSet _) -> "Data.Set.insert" - Just IntSet -> "Data.IntSet.insert" ) ++ args - | otherwise = normalExpr - - - prefixMod nt nm = "M_" ++ getName nt ++ "." ++ nm - -concatSeq = foldr (Seq.><) Seq.empty - -splitAttrs :: Map Identifier a -> [Identifier] -> ([(Identifier,a)],[Identifier]) -- a used as (String,String) -splitAttrs _ [] - = ([],[]) -splitAttrs useMap (n:rest) - = let (uses,normals) = splitAttrs useMap rest - in case Map.lookup n useMap of - Just x -> ((n,x):uses , normals ) - Nothing -> ( uses , n:normals ) - -removeDefined :: Set (Identifier,Identifier) -> (Identifier,Attributes) -> (Identifier,[Identifier]) -removeDefined defined (fld,as) - = ( fld - , [ a - | a <- Map.keys as - , not (Set.member (fld,a) defined) - ] - ) - + +fieldName n = '@' : getName n + +locName n = "@loc." ++ getName n + +attrName fld attr + | fld == _LOC = locName attr + | fld == _FIELD = fieldName attr + | otherwise = '@' : getName fld ++ "." ++ getName attr + +_ACHILD = Ident "(" noPos -- hack + +mkLocVar = AGField _LOC + +isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool +isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor + +buildConExpr ocaml clean conmap typeSyns rename nt con1 fs' + | nt `elem` map fst typeSyns = if ocaml then synonymMl + else if clean then synonymClean + else synonymHs + | otherwise = normalExpr + where fs = map fst fs' + con = getName con1 + tup = " " ++ buildTuple fs + args = " " ++ unwords fs + normalExpr = if clean && isRecordConstructor nt conmap + then "{" ++ con ++ "|" ++ + unwords (intersperse "," $ map (\(new, old) -> getName old ++ " = " ++ new) fs') + ++ "}" + else conname' ++ args + + conname' | rename = getName nt ++ "_" ++ getName con1 + | otherwise = getName con1 + + synonymHs | con == "Tuple" = buildTuple fs + | con == "Cons" = "(:)" ++ args + | con == "Nil" = case lookup nt typeSyns of + Just (Map _ _) -> "Data.Map.empty" + Just (IntMap _) -> "Data.IntMap.empty" + Just (OrdSet _) -> "Data.Set.empty" + Just IntSet -> "Data.IntSet.empty" + _ -> "[]" + | con == "Just" = "Just" ++ args + | con == "Nothing" = "Nothing" + | con == "Entry" = ( case lookup nt typeSyns of + Just (Map _ _) -> "Data.Map.insert" + Just (IntMap _) -> "Data.IntMap.insert" + Just (OrdSet _) -> "Data.Set.insert" + Just IntSet -> "Data.IntSet.insert" ) ++ args + | otherwise = normalExpr + + synonymMl | con == "Tuple" = buildTuple fs + | con == "Cons" = "(::)" ++ tup + | con == "Nil" = case lookup nt typeSyns of + Just (Map _ _) -> prefixMod nt "empty" + Just (IntMap _) -> prefixMod nt "empty" + Just (OrdSet _) -> prefixMod nt "empty" + Just IntSet -> prefixMod nt "empty" + _ -> "[]" + | con == "Just" = "Some" ++ tup + | con == "Nothing" = "None" + | con == "Entry" = ( case lookup nt typeSyns of + Just (Map _ _) -> prefixMod nt "add" + Just (IntMap _) -> prefixMod nt "add" + Just (OrdSet _) -> prefixMod nt "add" + Just IntSet -> prefixMod nt "add" ) ++ args + | otherwise = normalExpr + + synonymClean | con == "Tuple" = buildTuple fs + | con == "Cons" = "(\\x xs -> [x:xs])" ++ args + | con == "Nil" = case lookup nt typeSyns of + Just (Map _ _) -> "Data.Map.empty" + Just (IntMap _) -> "Data.IntMap.empty" + Just (OrdSet _) -> "Data.Set.empty" + Just IntSet -> "Data.IntSet.empty" + _ -> "[]" + | con == "Just" = "Just" ++ args + | con == "Nothing" = "Nothing" + | con == "Entry" = ( case lookup nt typeSyns of + Just (Map _ _) -> "Data.Map.insert" + Just (IntMap _) -> "Data.IntMap.insert" + Just (OrdSet _) -> "Data.Set.insert" + Just IntSet -> "Data.IntSet.insert" ) ++ args + | otherwise = normalExpr + + + prefixMod nt nm = "M_" ++ getName nt ++ "." ++ nm + +concatSeq = foldr (Seq.><) Seq.empty + +splitAttrs :: Map Identifier a -> [Identifier] -> ([(Identifier,a)],[Identifier]) -- a used as (String,String) +splitAttrs _ [] + = ([],[]) +splitAttrs useMap (n:rest) + = let (uses,normals) = splitAttrs useMap rest + in case Map.lookup n useMap of + Just x -> ((n,x):uses , normals ) + Nothing -> ( uses , n:normals ) + +removeDefined :: Set (Identifier,Identifier) -> (Identifier,Attributes) -> (Identifier,[Identifier]) +removeDefined defined (fld,as) + = ( fld + , [ a + | a <- Map.keys as + , not (Set.member (fld,a) defined) + ] + ) + {-# LINE 159 "src-generated/DefaultRules.hs" #-} {-# LINE 255 "src-ag/DefaultRules.ag" #-} - - - - -deprecatedCopyRuleError nt con fld a - = let mesg = - "In the definitions for alternative" - >#< getName con - >#< "of nonterminal" - >#< getName nt - >|< "," - >-< "the value of field" - >#< getName a - >#< "is copied by a copy-rule." - >-< "Copying the value of a field using a copy-rule is deprecated" - >-< "Please add the following lines to your code:" - >-< ( "SEM" - >#< getName nt - >-< indent 2 ( "|" - >#< getName con - >#< getName fld - >#< "." - >#< a - >#< "=" - >#< "@" - >|< a - ) - ) - in CustomError True (getPos a) mesg - - -missingRuleErrorExpr clean nt con fld a - = (if clean then "abort" else "error") - ++ " \"missing rule: " - ++ show nt ++ "." ++ show con ++ "." - ++ show fld ++ "." ++ show a ++ "\"" - -makeRule :: (Identifier,Identifier) -> Expression -> String -> Bool -> Maybe Error -> Rule -makeRule (f1,a1) expr origin identity mbDelayedError - = Rule Nothing - (Alias f1 a1 (Underscore noPos)) - expr - False - origin - False - True - identity - mbDelayedError - False - - -useRule :: Options -> Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule -useRule opts locals ch_outs (n,(op,e,pos)) - = let elems = [ fld - | (fld,as) <- ch_outs - , Map.member n as - ] - - isOp [] = False - isOp (c:cs) - | isSpace c = isOp cs - | isAlpha c = case dropWhile isAlpha cs of - ('.':cs2) -> isOp cs2 -- fully qualified name, drop prefix - _ -> False - | c == '(' = False - | otherwise = True - - tks | Set.member n locals = [mkLocVar n noPos Nothing] - | null elems = lexTokens opts noPos e - | otherwise = lexTokens opts noPos str - where - opExpr l r - | isOp op = l ++ " " ++ op ++ " " ++ r -- takes the associativity of the operator - | otherwise = "(" ++ op ++ " " ++ l ++ " " ++ r ++ ")" -- associates to the right - str = foldr1 opExpr (map (flip attrName n) elems) - - in makeRule (_LHS,n) - (Expression noPos tks) - ("use rule " ++ pos) - False - Nothing - - -selfRule :: Bool -> Identifier -> [HsToken] -> Rule -selfRule lhsNecLoc attr tks - = makeRule (if lhsNecLoc then _LHS else _LOC,attr) - (Expression noPos tks) - "self rule" - False - Nothing - - - - -concatRE rsess = let (rss,ess) = unzip rsess - in (concat rss, concatSeq ess) - - -copyRule :: Options -> Set NontermIdent -> Identifier -> Identifier -> Bool -> Set Identifier -> (Map Identifier Identifier, (Identifier,[Identifier])) -> ([Rule], Seq Error) -copyRule options wrappers nt con modcopy locals (env,(fld,as)) - = concatRE (map copyRu as) - - where - copyRu a - = ( [ makeRule (fld,a) - (Expression noPos tks) - (cruletxt sel) - True - mbDelayedErr - ] - , err - ) - - where - sel - | not modcopy - && Set.member a locals = Just _LOC - | otherwise = Map.lookup a env - - (tks,err,mbDelayedErr) - = case sel of - Nothing -> let tks = [HsToken (missingRuleErrorExpr (clean options) nt con fld a) noPos] - err = MissingRule nt con fld a - in if nt `Set.member` wrappers && kennedyWarren options - then (tks, Seq.empty, Just err) -- yield error only if the rule is actually scheduled; for kennedyWarren code gen only - else (tks, Seq.singleton err, Nothing) - Just f - | f == _ACHILD -> ( [AGLocal a noPos Nothing] - , Seq.singleton (deprecatedCopyRuleError nt con fld a) - , Nothing - ) - | otherwise -> ( [AGField f a noPos Nothing] - , Seq.empty - , Nothing - ) - - cruletxt sel - | local = "copy rule (from local)" - | deprChild = "deprecated child copy" - | Set.member a locals && nonlocal = "modified copy rule" - | incoming && outgoing = "copy rule (chain)" - | incoming = "copy rule (down)" - | outgoing = "copy rule (up)" - | otherwise = "copy rule (chain)" - where outgoing = fld == _LHS - incoming = maybe False (== _LHS) sel - nonlocal = maybe False (/= _LOC) sel - local = maybe False (== _LOC) sel - deprChild = maybe False (== _ACHILD) sel + + + + +deprecatedCopyRuleError nt con fld a + = let mesg = + "In the definitions for alternative" + >#< getName con + >#< "of nonterminal" + >#< getName nt + >|< "," + >-< "the value of field" + >#< getName a + >#< "is copied by a copy-rule." + >-< "Copying the value of a field using a copy-rule is deprecated" + >-< "Please add the following lines to your code:" + >-< ( "SEM" + >#< getName nt + >-< indent 2 ( "|" + >#< getName con + >#< getName fld + >#< "." + >#< a + >#< "=" + >#< "@" + >|< a + ) + ) + in CustomError True (getPos a) mesg + + +missingRuleErrorExpr clean nt con fld a + = (if clean then "abort" else "error") + ++ " \"missing rule: " + ++ show nt ++ "." ++ show con ++ "." + ++ show fld ++ "." ++ show a ++ "\"" + +makeRule :: (Identifier,Identifier) -> Expression -> String -> Bool -> Maybe Error -> Rule +makeRule (f1,a1) expr origin identity mbDelayedError + = Rule Nothing + (Alias f1 a1 (Underscore noPos)) + expr + False + origin + False + True + identity + mbDelayedError + False + + +useRule :: Options -> Set Identifier -> [(Identifier,Attributes)] -> (Identifier,(String,String,String)) -> Rule +useRule opts locals ch_outs (n,(op,e,pos)) + = let elems = [ fld + | (fld,as) <- ch_outs + , Map.member n as + ] + + isOp [] = False + isOp (c:cs) + | isSpace c = isOp cs + | isAlpha c = case dropWhile isAlpha cs of + ('.':cs2) -> isOp cs2 -- fully qualified name, drop prefix + _ -> False + | c == '(' = False + | otherwise = True + + tks | Set.member n locals = [mkLocVar n noPos Nothing] + | null elems = lexTokens opts noPos e + | otherwise = lexTokens opts noPos str + where + opExpr l r + | isOp op = l ++ " " ++ op ++ " " ++ r -- takes the associativity of the operator + | otherwise = "(" ++ op ++ " " ++ l ++ " " ++ r ++ ")" -- associates to the right + str = foldr1 opExpr (map (flip attrName n) elems) + + in makeRule (_LHS,n) + (Expression noPos tks) + ("use rule " ++ pos) + False + Nothing + + +selfRule :: Bool -> Identifier -> [HsToken] -> Rule +selfRule lhsNecLoc attr tks + = makeRule (if lhsNecLoc then _LHS else _LOC,attr) + (Expression noPos tks) + "self rule" + False + Nothing + + + + +concatRE rsess = let (rss,ess) = unzip rsess + in (concat rss, concatSeq ess) + + +copyRule :: Options -> Set NontermIdent -> Identifier -> Identifier -> Bool -> Set Identifier -> (Map Identifier Identifier, (Identifier,[Identifier])) -> ([Rule], Seq Error) +copyRule options wrappers nt con modcopy locals (env,(fld,as)) + = concatRE (map copyRu as) + + where + copyRu a + = ( [ makeRule (fld,a) + (Expression noPos tks) + (cruletxt sel) + True + mbDelayedErr + ] + , err + ) + + where + sel + | not modcopy + && Set.member a locals = Just _LOC + | otherwise = Map.lookup a env + + (tks,err,mbDelayedErr) + = case sel of + Nothing -> let tks = [HsToken (missingRuleErrorExpr (clean options) nt con fld a) noPos] + err = MissingRule nt con fld a + in if nt `Set.member` wrappers && kennedyWarren options + then (tks, Seq.empty, Just err) -- yield error only if the rule is actually scheduled; for kennedyWarren code gen only + else (tks, Seq.singleton err, Nothing) + Just f + | f == _ACHILD -> ( [AGLocal a noPos Nothing] + , Seq.singleton (deprecatedCopyRuleError nt con fld a) + , Nothing + ) + | otherwise -> ( [AGField f a noPos Nothing] + , Seq.empty + , Nothing + ) + + cruletxt sel + | local = "copy rule (from local)" + | deprChild = "deprecated child copy" + | Set.member a locals && nonlocal = "modified copy rule" + | incoming && outgoing = "copy rule (chain)" + | incoming = "copy rule (down)" + | outgoing = "copy rule (up)" + | otherwise = "copy rule (chain)" + where outgoing = fld == _LHS + incoming = maybe False (== _LHS) sel + nonlocal = maybe False (/= _LOC) sel + local = maybe False (== _LOC) sel + deprChild = maybe False (== _ACHILD) sel {-# LINE 311 "src-generated/DefaultRules.hs" #-} {-# LINE 488 "src-ag/DefaultRules.ag" #-} - -buildTuple fs = "(" ++ concat (intersperse "," fs) ++ ")" - -addAugments :: (Identifier, [Expression]) -> [Rule] -> [Rule] -addAugments (_, exprs) rules - | null exprs = rules -addAugments (syn, exprs) rules - = [rule] ++ funRules ++ map modify rules - where - rule = Rule Nothing (Alias _LHS syn (Underscore noPos)) rhs False "augmented rule" False True False Nothing False - rhs = Expression noPos tks - tks = [ HsToken "foldr ($) " noPos, mkLocVar substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos] - funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames) - - substSyn = Ident (show syn ++ "_augmented_syn") (getPos syn) - funNames = zipWith (\i _ -> Ident (show syn ++ "_augmented_f" ++ show i) (getPos syn)) [1..] exprs - funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "augment function" False True False Nothing False) funNames exprs - - modify (Rule mbNm pat rhs owrt origin expl pure identity mbErr eager) - | containsSyn pat = Rule mbNm (modifyPat pat) rhs owrt origin expl pure identity mbErr eager - modify r = r - - containsSyn (Constr _ pats) = any containsSyn pats - containsSyn (Product _ pats) = any containsSyn pats - containsSyn (Irrefutable pat) = containsSyn pat - containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat - containsSyn _ = False - - modifyPat (Constr name pats) = Constr name (map modifyPat pats) - modifyPat (Product pos pats) = Product pos (map modifyPat pats) - modifyPat (Irrefutable pat) = Irrefutable (modifyPat pat) - modifyPat (Alias field attr pat) - | field == _LHS && attr == syn = Alias _LOC substSyn (modifyPat pat) - | otherwise = Alias field attr (modifyPat pat) - modifyPat p = p - --- adds the additional rules needed for around, which creates a sequence of --- rules that form a function that each transforms the semantics of a child --- before attaching the child. --- The rule defines a local attribute "_around" and is dependent --- on this attribute. -addArounds :: (Identifier, [Expression]) -> [Rule] -> [Rule] -addArounds (_, exprs) rules | null exprs = rules -addArounds (child, exprs) rules - = [rule] ++ funRules ++ rules - where - rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) rhs False "around rule" False True False Nothing False - rhs = Expression noPos tks - tks = [ HsToken "\\s -> foldr ($) s " noPos, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos] - funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames) - - childLoc = Ident (show child ++ "_around") (getPos child) - funNames = zipWith (\i _ -> Ident (show child ++ "_around_f" ++ show i) (getPos child)) [1..] exprs - funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "around function" False True False Nothing False) funNames exprs - --- adds the additional rules needed for merging. --- It produces for each merging child a rule with local attribute: "_merged". --- this rules takes the semantics of the first children and feeds it to the function --- represented by this attribute. This attribute then defines the semantics for --- the merging child. -addMerges :: (Identifier, (Identifier,[Identifier],Expression)) -> [Rule] -> [Rule] -addMerges (target,(_,_,expr)) rules - = rule : rules - where - rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) expr False "merge rule" False True False Nothing False - childLoc = Ident (show target ++ "_merge") (getPos target) + +buildTuple fs = "(" ++ concat (intersperse "," fs) ++ ")" + +addAugments :: (Identifier, [Expression]) -> [Rule] -> [Rule] +addAugments (_, exprs) rules + | null exprs = rules +addAugments (syn, exprs) rules + = [rule] ++ funRules ++ map modify rules + where + rule = Rule Nothing (Alias _LHS syn (Underscore noPos)) rhs False "augmented rule" False True False Nothing False + rhs = Expression noPos tks + tks = [ HsToken "foldr ($) " noPos, mkLocVar substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos] + funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames) + + substSyn = Ident (show syn ++ "_augmented_syn") (getPos syn) + funNames = zipWith (\i _ -> Ident (show syn ++ "_augmented_f" ++ show i) (getPos syn)) [1..] exprs + funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "augment function" False True False Nothing False) funNames exprs + + modify (Rule mbNm pat rhs owrt origin expl pure identity mbErr eager) + | containsSyn pat = Rule mbNm (modifyPat pat) rhs owrt origin expl pure identity mbErr eager + modify r = r + + containsSyn (Constr _ pats) = any containsSyn pats + containsSyn (Product _ pats) = any containsSyn pats + containsSyn (Irrefutable pat) = containsSyn pat + containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat + containsSyn _ = False + + modifyPat (Constr name pats) = Constr name (map modifyPat pats) + modifyPat (Product pos pats) = Product pos (map modifyPat pats) + modifyPat (Irrefutable pat) = Irrefutable (modifyPat pat) + modifyPat (Alias field attr pat) + | field == _LHS && attr == syn = Alias _LOC substSyn (modifyPat pat) + | otherwise = Alias field attr (modifyPat pat) + modifyPat p = p + +-- adds the additional rules needed for around, which creates a sequence of +-- rules that form a function that each transforms the semantics of a child +-- before attaching the child. +-- The rule defines a local attribute "_around" and is dependent +-- on this attribute. +addArounds :: (Identifier, [Expression]) -> [Rule] -> [Rule] +addArounds (_, exprs) rules | null exprs = rules +addArounds (child, exprs) rules + = [rule] ++ funRules ++ rules + where + rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) rhs False "around rule" False True False Nothing False + rhs = Expression noPos tks + tks = [ HsToken "\\s -> foldr ($) s " noPos, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos] + funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames) + + childLoc = Ident (show child ++ "_around") (getPos child) + funNames = zipWith (\i _ -> Ident (show child ++ "_around_f" ++ show i) (getPos child)) [1..] exprs + funRules = zipWith (\name expr -> Rule Nothing (Alias _LOC name (Underscore noPos)) expr False "around function" False True False Nothing False) funNames exprs + +-- adds the additional rules needed for merging. +-- It produces for each merging child a rule with local attribute: "_merged". +-- this rules takes the semantics of the first children and feeds it to the function +-- represented by this attribute. This attribute then defines the semantics for +-- the merging child. +addMerges :: (Identifier, (Identifier,[Identifier],Expression)) -> [Rule] -> [Rule] +addMerges (target,(_,_,expr)) rules + = rule : rules + where + rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) expr False "merge rule" False True False Nothing False + childLoc = Ident (show target ++ "_merge") (getPos target) {-# LINE 380 "src-generated/DefaultRules.hs" #-} {-# LINE 606 "src-ag/DefaultRules.ag" #-} - -elimSelfId :: NontermIdent -> [Identifier] -> Type -> Type -elimSelfId nt args Self = NT nt (map getName args) False -elimSelfId _ _ tp = tp - -elimSelfStr :: NontermIdent -> [String] -> Type -> Type -elimSelfStr nt args Self = NT nt args False -elimSelfStr _ _ tp = tp + +elimSelfId :: NontermIdent -> [Identifier] -> Type -> Type +elimSelfId nt args Self = NT nt (map getName args) False +elimSelfId _ _ tp = tp + +elimSelfStr :: NontermIdent -> [String] -> Type -> Type +elimSelfStr nt args Self = NT nt args False +elimSelfStr _ _ tp = tp {-# LINE 391 "src-generated/DefaultRules.hs" #-} {-# LINE 658 "src-ag/DefaultRules.ag" #-} - --- When a rule has a name, create an alias for a rule --- and a modified rule that refers to the alias --- Thus it removes rule names from rules -mkRuleAlias :: Rule -> (Rule, Maybe Rule) -mkRuleAlias r@(Rule Nothing _ _ _ _ _ _ _ _ _) = (r, Nothing) -mkRuleAlias (Rule (Just nm) pat expr owrt origin expl pure identity mbErr eager) = (r', Just alias) where - alias = Rule Nothing (Alias _LOC (Ident ("_rule_" ++ show nm) pos) (Underscore pos)) expr owrt origin expl pure identity mbErr eager - pos = getPos nm - expr' = Expression pos tks - tks = [mkLocVar (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))] - r' = Rule Nothing pat expr' owrt origin False True identity Nothing False + +-- When a rule has a name, create an alias for a rule +-- and a modified rule that refers to the alias +-- Thus it removes rule names from rules +mkRuleAlias :: Rule -> (Rule, Maybe Rule) +mkRuleAlias r@(Rule Nothing _ _ _ _ _ _ _ _ _) = (r, Nothing) +mkRuleAlias (Rule (Just nm) pat expr owrt origin expl pure identity mbErr eager) = (r', Just alias) where + alias = Rule Nothing (Alias _LOC (Ident ("_rule_" ++ show nm) pos) (Underscore pos)) expr owrt origin expl pure identity mbErr eager + pos = getPos nm + expr' = Expression pos tks + tks = [mkLocVar (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))] + r' = Rule Nothing pat expr' owrt origin False True identity Nothing False {-# LINE 406 "src-generated/DefaultRules.hs" #-} {-# LINE 675 "src-ag/DefaultRules.ag" #-} - -needsMultiRules :: Options -> Bool -needsMultiRules opts = (visit opts || withCycle opts) && not (kennedyWarren opts) + +needsMultiRules :: Options -> Bool +needsMultiRules opts = (visit opts || withCycle opts) && not (kennedyWarren opts) {-# LINE 412 "src-generated/DefaultRules.hs" #-} {-# LINE 680 "src-ag/DefaultRules.ag" #-} - -{- -multiRule replaces - loc.(a,b) = e -by - loc.tup1 = e - loc.(a,_) = @loc.tup1 - loc.(_,b) = @loc.tup1 -It needs to thread a unique number for inventing names for the tuples. - -It also works for nested tuples: - loc.(a,(b,c)) = e -becomes - loc.tup1 = e - loc.(a,_) = @loc.tup1 - loc.(_,tup2) = @loc.tup1 - loc.(b,_) = @loc.tup2 - loc.(_,c) = @loc.tup2 --} - -multiRule :: Rule -> Int -> ([Rule], Int) -multiRule (Rule _ pat expr owrt origin expl pure identity mbErr eager) uniq - = let f :: Bool -> (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int)) - f expl' w e (Product pos pats) n - = let freshName = Ident ("_tup" ++ show n) pos - freshExpr = Expression pos freshTks - freshTks = [AGField _LOC freshName pos Nothing] - freshPat = Alias _LOC freshName (Underscore pos) - a = length pats - 1 - us b p = Product pos (replicate (a-b) (Underscore pos) ++ [p] ++ replicate b (Underscore pos)) - g :: Pattern -> ([Pattern],[Rule],Int) -> ([Pattern],[Rule],Int) - g p (xs1,rs1,n1) = let (x2,(rs2,n2)) = f False (us (length xs1)) freshExpr p n1 - in (x2:xs1, rs2++rs1, n2) - (xs9,rs9,n9) = foldr g ([], [], n+1) pats - in ( freshPat - , ( Rule Nothing (w freshPat) e owrt origin expl' True False mbErr eager : rs9 - , n9 - ) - ) - f expl' w e p n - = ( p - , ( [Rule Nothing (w p) e owrt origin expl' True False mbErr eager] - , n - ) - ) - in snd (f expl id expr pat uniq) - + +{- +multiRule replaces + loc.(a,b) = e +by + loc.tup1 = e + loc.(a,_) = @loc.tup1 + loc.(_,b) = @loc.tup1 +It needs to thread a unique number for inventing names for the tuples. + +It also works for nested tuples: + loc.(a,(b,c)) = e +becomes + loc.tup1 = e + loc.(a,_) = @loc.tup1 + loc.(_,tup2) = @loc.tup1 + loc.(b,_) = @loc.tup2 + loc.(_,c) = @loc.tup2 +-} + +multiRule :: Rule -> Int -> ([Rule], Int) +multiRule (Rule _ pat expr owrt origin expl pure identity mbErr eager) uniq + = let f :: Bool -> (Pattern->Pattern) -> Expression -> Pattern -> Int -> (Pattern, ([Rule], Int)) + f expl' w e (Product pos pats) n + = let freshName = Ident ("_tup" ++ show n) pos + freshExpr = Expression pos freshTks + freshTks = [AGField _LOC freshName pos Nothing] + freshPat = Alias _LOC freshName (Underscore pos) + a = length pats - 1 + us b p = Product pos (replicate (a-b) (Underscore pos) ++ [p] ++ replicate b (Underscore pos)) + g :: Pattern -> ([Pattern],[Rule],Int) -> ([Pattern],[Rule],Int) + g p (xs1,rs1,n1) = let (x2,(rs2,n2)) = f False (us (length xs1)) freshExpr p n1 + in (x2:xs1, rs2++rs1, n2) + (xs9,rs9,n9) = foldr g ([], [], n+1) pats + in ( freshPat + , ( Rule Nothing (w freshPat) e owrt origin expl' True False mbErr eager : rs9 + , n9 + ) + ) + f expl' w e p n + = ( p + , ( [Rule Nothing (w p) e owrt origin expl' True False mbErr eager] + , n + ) + ) + in snd (f expl id expr pat uniq) + {-# LINE 462 "src-generated/DefaultRules.hs" #-} -- Child ------------------------------------------------------- -- wrapper diff --git a/src-generated/Desugar.hs b/src-generated/Desugar.hs --- a/src-generated/Desugar.hs +++ b/src-generated/Desugar.hs @@ -4,118 +4,118 @@ module Desugar where {-# LINE 2 "src-ag/HsToken.ag" #-} - -import CommonTypes -import UU.Scanner.Position(Pos) + +import CommonTypes +import UU.Scanner.Position(Pos) {-# LINE 11 "src-generated/Desugar.hs" #-} {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 17 "src-generated/Desugar.hs" #-} {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 24 "src-generated/Desugar.hs" #-} {-# LINE 2 "src-ag/AbstractSyntax.ag" #-} - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import Macro --marcos -import CommonTypes -import ErrorMessages + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import Macro --marcos +import CommonTypes +import ErrorMessages {-# LINE 36 "src-generated/Desugar.hs" #-} {-# LINE 14 "src-ag/Desugar.ag" #-} - -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq,(><)) -import UU.Scanner.Position(Pos(..)) -import Data.Maybe -import Data.List(intersperse) - -import AbstractSyntax -import ErrorMessages -import Options -import HsToken -import HsTokenScanner -import TokenDef -import CommonTypes + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Sequence as Seq +import Data.Sequence(Seq,(><)) +import UU.Scanner.Position(Pos(..)) +import Data.Maybe +import Data.List(intersperse) + +import AbstractSyntax +import ErrorMessages +import Options +import HsToken +import HsTokenScanner +import TokenDef +import CommonTypes {-# LINE 56 "src-generated/Desugar.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 98 "src-ag/Desugar.ag" #-} - -addl :: Int -> Pos -> Pos -addl n (Pos l c f) = Pos (l+n) c f + +addl :: Int -> Pos -> Pos +addl n (Pos l c f) = Pos (l+n) c f {-# LINE 63 "src-generated/Desugar.hs" #-} {-# LINE 133 "src-ag/Desugar.ag" #-} - -maybeError :: a -> Error -> Maybe a -> (a, Seq Error) -maybeError def err mb - = maybe (def, Seq.singleton err) (\r -> (r, Seq.empty)) mb - -findField :: Identifier -> Identifier -> [(Identifier,Identifier)] -> Maybe Identifier -findField fld attr list - | fld == _FIRST = f list - | fld == _LAST = f (reverse list) - | otherwise = Just fld - where - f = lookup attr + +maybeError :: a -> Error -> Maybe a -> (a, Seq Error) +maybeError def err mb + = maybe (def, Seq.singleton err) (\r -> (r, Seq.empty)) mb + +findField :: Identifier -> Identifier -> [(Identifier,Identifier)] -> Maybe Identifier +findField fld attr list + | fld == _FIRST = f list + | fld == _LAST = f (reverse list) + | otherwise = Just fld + where + f = lookup attr {-# LINE 78 "src-generated/Desugar.hs" #-} {-# LINE 204 "src-ag/Desugar.ag" #-} - -mergeAttributes :: AttrMap -> AttrMap -> AttrMap -mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union + +mergeAttributes :: AttrMap -> AttrMap -> AttrMap +mergeAttributes = Map.unionWith $ Map.unionWith $ Set.union {-# LINE 84 "src-generated/Desugar.hs" #-} {-# LINE 251 "src-ag/Desugar.ag" #-} - -desugarExprs :: Options -> NontermIdent -> ConstructorIdent -> - [(Identifier, Identifier)] -> [(Identifier, Identifier)] -> - Seq Error -> [Expression] -> (Seq Error, [Expression]) -desugarExprs options nt con childInhs childSyns - = mapAccum (desugarExpr options nt con childInhs childSyns) - where mapAccum f e = foldr (\x (e0,xs) -> let (e1,x') = f e0 x in (e1, x:xs)) (e, []) - -desugarExpr :: Options -> NontermIdent -> ConstructorIdent -> - [(Identifier, Identifier)] -> [(Identifier, Identifier)] -> - Seq Error -> Expression -> (Seq Error, Expression) -desugarExpr options nt con childInhs childSyns errs expr - = (errs Seq.>< errors_Syn_Expression syn, output_Syn_Expression syn) - where - inh = Inh_Expression { childInhs_Inh_Expression = childInhs - , childSyns_Inh_Expression = childSyns - , con_Inh_Expression = con - , nt_Inh_Expression = nt - , options_Inh_Expression = options - , ruleDescr_Inh_Expression = "augment-rule" - } - sem = sem_Expression expr - syn = wrap_Expression sem inh + +desugarExprs :: Options -> NontermIdent -> ConstructorIdent -> + [(Identifier, Identifier)] -> [(Identifier, Identifier)] -> + Seq Error -> [Expression] -> (Seq Error, [Expression]) +desugarExprs options nt con childInhs childSyns + = mapAccum (desugarExpr options nt con childInhs childSyns) + where mapAccum f e = foldr (\x (e0,xs) -> let (e1,x') = f e0 x in (e1, x:xs)) (e, []) + +desugarExpr :: Options -> NontermIdent -> ConstructorIdent -> + [(Identifier, Identifier)] -> [(Identifier, Identifier)] -> + Seq Error -> Expression -> (Seq Error, Expression) +desugarExpr options nt con childInhs childSyns errs expr + = (errs Seq.>< errors_Syn_Expression syn, output_Syn_Expression syn) + where + inh = Inh_Expression { childInhs_Inh_Expression = childInhs + , childSyns_Inh_Expression = childSyns + , con_Inh_Expression = con + , nt_Inh_Expression = nt + , options_Inh_Expression = options + , ruleDescr_Inh_Expression = "augment-rule" + } + sem = sem_Expression expr + syn = wrap_Expression sem inh {-# LINE 110 "src-generated/Desugar.hs" #-} {-# LINE 294 "src-ag/Desugar.ag" #-} - -addLateAttr :: Options -> String -> Attributes -addLateAttr options mainName - | kennedyWarren options && lateHigherOrderBinding options = - let tp = lateBindingType mainName - in Map.singleton idLateBindingAttr tp - | otherwise = Map.empty + +addLateAttr :: Options -> String -> Attributes +addLateAttr options mainName + | kennedyWarren options && lateHigherOrderBinding options = + let tp = lateBindingType mainName + in Map.singleton idLateBindingAttr tp + | otherwise = Map.empty {-# LINE 120 "src-generated/Desugar.hs" #-} -- Child ------------------------------------------------------- -- wrapper diff --git a/src-generated/ErrorMessages.hs b/src-generated/ErrorMessages.hs --- a/src-generated/ErrorMessages.hs +++ b/src-generated/ErrorMessages.hs @@ -3,11 +3,11 @@ -- UUAGC 0.9.53 (src-ag/ErrorMessages.ag) module ErrorMessages where {-# LINE 2 "src-ag/ErrorMessages.ag" #-} - -import UU.Scanner.Position(Pos) -import Pretty -import CodeSyntax -import CommonTypes + +import UU.Scanner.Position(Pos) +import Pretty +import CodeSyntax +import CommonTypes {-# LINE 12 "src-generated/ErrorMessages.hs" #-} -- Error ------------------------------------------------------- {- diff --git a/src-generated/ExecutionPlan.hs b/src-generated/ExecutionPlan.hs --- a/src-generated/ExecutionPlan.hs +++ b/src-generated/ExecutionPlan.hs @@ -3,17 +3,17 @@ -- UUAGC 0.9.53 (src-ag/ExecutionPlan.ag) module ExecutionPlan where {-# LINE 2 "src-ag/ExecutionPlan.ag" #-} - --- VisitSyntax.ag imports -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import CommonTypes -import ErrorMessages - -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Map as Map -import Data.Map(Map) + +-- VisitSyntax.ag imports +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes +import ErrorMessages + +import qualified Data.Set as Set +import Data.Set(Set) +import qualified Data.Map as Map +import Data.Map(Map) {-# LINE 18 "src-generated/ExecutionPlan.hs" #-} -- EChild ------------------------------------------------------ {- diff --git a/src-generated/ExecutionPlan2Caml.hs b/src-generated/ExecutionPlan2Caml.hs --- a/src-generated/ExecutionPlan2Caml.hs +++ b/src-generated/ExecutionPlan2Caml.hs @@ -3,134 +3,134 @@ module ExecutionPlan2Caml where {-# LINE 2 "src-ag/HsToken.ag" #-} - -import CommonTypes -import UU.Scanner.Position(Pos) + +import CommonTypes +import UU.Scanner.Position(Pos) {-# LINE 10 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 16 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 23 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 2 "src-ag/ExecutionPlan.ag" #-} - --- VisitSyntax.ag imports -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import CommonTypes -import ErrorMessages - -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Map as Map -import Data.Map(Map) + +-- VisitSyntax.ag imports +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes +import ErrorMessages + +import qualified Data.Set as Set +import Data.Set(Set) +import qualified Data.Map as Map +import Data.Map(Map) {-# LINE 37 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 32 "src-ag/ExecutionPlan2Caml.ag" #-} - -import ExecutionPlan -import Pretty -import PPUtil -import Options -import Data.Monoid(mappend,mempty) -import Data.Maybe -import Data.Graph -import Debug.Trace -import System.IO -import System.Directory -import System.FilePath -import UU.Scanner.Position - -import TokenDef -import HsToken -import ErrorMessages - -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Sequence(Seq) -import qualified Data.Sequence as Seq -import Data.Foldable(toList) + +import ExecutionPlan +import Pretty +import PPUtil +import Options +import Data.Monoid(mappend,mempty) +import Data.Maybe +import Data.Graph +import Debug.Trace +import System.IO +import System.Directory +import System.FilePath +import UU.Scanner.Position + +import TokenDef +import HsToken +import ErrorMessages + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Sequence(Seq) +import qualified Data.Sequence as Seq +import Data.Foldable(toList) {-# LINE 65 "src-generated/ExecutionPlan2Caml.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 175 "src-ag/ExecutionPlan2Caml.ag" #-} - -ppRecordTp :: PP a => [a] -> PP_Doc -ppRecordTp es - | null es = text "unit" - | otherwise = pp_block "{" "}" "; " (map pp es) - -ppRecordVal :: PP a => [a] -> PP_Doc -ppRecordVal es - | null es = text "()" - | otherwise = pp_block "{" "}" "; " (map pp es) - -ppFieldsVal :: Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc -ppFieldsVal record fields - | null fields = text "()" - | record = ppRecordVal [ r >#< "=" >#< x | (r,x,_,_) <- fields ] - | otherwise = pp_block "(" ")" "," [ x | (_,x,_,_) <- fields ] - -ppFieldsType :: Bool -> Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc -ppFieldsType record defor fields - | null fields = text "unit" - | record = ppRecordTp [ r >#< ":" >#< (if defor then d else f) | (r,_,d,f) <- fields ] - | otherwise = pp_block "(" ")" "*" [ if defor then d else f | (_,_,d,f) <- fields ] + +ppRecordTp :: PP a => [a] -> PP_Doc +ppRecordTp es + | null es = text "unit" + | otherwise = pp_block "{" "}" "; " (map pp es) + +ppRecordVal :: PP a => [a] -> PP_Doc +ppRecordVal es + | null es = text "()" + | otherwise = pp_block "{" "}" "; " (map pp es) + +ppFieldsVal :: Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc +ppFieldsVal record fields + | null fields = text "()" + | record = ppRecordVal [ r >#< "=" >#< x | (r,x,_,_) <- fields ] + | otherwise = pp_block "(" ")" "," [ x | (_,x,_,_) <- fields ] + +ppFieldsType :: Bool -> Bool -> [(PP_Doc,PP_Doc,PP_Doc,PP_Doc)] -> PP_Doc +ppFieldsType record defor fields + | null fields = text "unit" + | record = ppRecordTp [ r >#< ":" >#< (if defor then d else f) | (r,_,d,f) <- fields ] + | otherwise = pp_block "(" ")" "*" [ if defor then d else f | (_,_,d,f) <- fields ] {-# LINE 91 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 288 "src-ag/ExecutionPlan2Caml.ag" #-} - -ppTp :: Type -> PP_Doc -ppTp tp = case tp of - Haskell t -> pp t -- ocaml type - NT nt tps deforested - | nt == _SELF -> pp "?SELF?" - | null tps -> ppNontTp nt deforested - | otherwise -> pp_parens (ppSpaced (map pp_parens tps) >#< ppNontTp nt deforested) - Self -> pp "?SELF?" - -ppNontTp :: NontermIdent -> Bool -> PP_Doc -ppNontTp nt True = pp "t_" >|< pp nt -ppNontTp nt False = pp nt - --- multiple type parameters go into a tuple -ppTypeParams :: PP a => [a] -> PP_Doc -ppTypeParams [] = empty -ppTypeParams [x] = pp x -ppTypeParams xs = pp_block "(" ")" "," (map pp xs) + +ppTp :: Type -> PP_Doc +ppTp tp = case tp of + Haskell t -> pp t -- ocaml type + NT nt tps deforested + | nt == _SELF -> pp "?SELF?" + | null tps -> ppNontTp nt deforested + | otherwise -> pp_parens (ppSpaced (map pp_parens tps) >#< ppNontTp nt deforested) + Self -> pp "?SELF?" + +ppNontTp :: NontermIdent -> Bool -> PP_Doc +ppNontTp nt True = pp "t_" >|< pp nt +ppNontTp nt False = pp nt + +-- multiple type parameters go into a tuple +ppTypeParams :: PP a => [a] -> PP_Doc +ppTypeParams [] = empty +ppTypeParams [x] = pp x +ppTypeParams xs = pp_block "(" ")" "," (map pp xs) {-# LINE 113 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 361 "src-ag/ExecutionPlan2Caml.ag" #-} - --- convention for nonterminals to module names -modName :: NontermIdent -> PP_Doc -modName nt = pp "M_" >|< pp nt - -ppFunDecl :: Bool -> PP_Doc -> [(PP_Doc,PP_Doc)] -> PP_Doc -> PP_Doc -> PP_Doc -ppFunDecl gensigs nm args resSig expr = body where - body = nm >#< ppSpaced (map arg args) >#< ppRes >#< "=" - >-< indent 2 expr - arg (arg,tp) = ppArg gensigs arg tp - ppRes - | gensigs = ":" >#< resSig - | otherwise = empty - -ppArg :: Bool -> PP_Doc -> PP_Doc -> PP_Doc -ppArg gensigs arg tp - | gensigs = pp_parens (arg >#< ":" >#< tp) - | otherwise = arg - + +-- convention for nonterminals to module names +modName :: NontermIdent -> PP_Doc +modName nt = pp "M_" >|< pp nt + +ppFunDecl :: Bool -> PP_Doc -> [(PP_Doc,PP_Doc)] -> PP_Doc -> PP_Doc -> PP_Doc +ppFunDecl gensigs nm args resSig expr = body where + body = nm >#< ppSpaced (map arg args) >#< ppRes >#< "=" + >-< indent 2 expr + arg (arg,tp) = ppArg gensigs arg tp + ppRes + | gensigs = ":" >#< resSig + | otherwise = empty + +ppArg :: Bool -> PP_Doc -> PP_Doc -> PP_Doc +ppArg gensigs arg tp + | gensigs = pp_parens (arg >#< ":" >#< tp) + | otherwise = arg + {-# LINE 135 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 428 "src-ag/ExecutionPlan2Caml.ag" #-} @@ -138,182 +138,182 @@ {-# LINE 139 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 464 "src-ag/ExecutionPlan2Caml.ag" #-} - --- --- conventions --- - --- type of the state of a node: a closure containing the children states and attributes, --- with code of type 'type_nt_sem' that represents the subsequent visits to successor states. -type_nt_state nt st = "s_" >|< nt >|< "_" >|< st - --- type of a visit to a node (the initial, and when in a given state) --- an instance of this type is called the "semantics" -type_nt_sem_top nt = "t_" >|< nt -type_nt_sem nt st = type_nt_sem_top nt >|< "_s" >|< st - --- type of a caller (contains visit selection + inputs + continuation) -type_caller nt st = "c_" >|< nt >|< "_s" >|< st - --- names of records -nm_attach nt = "attach_">|< nt -nm_invoke nt st = "inv_" >|< nt >|< "_s" >|< st - --- name of the type variable representing the result type of the continuation -cont_tvar = text "'cont__" - - --- order states in reverse topological order so that successor states are --- earlier in the resulting list. -orderStates :: StateIdentifier -> [VisitStateState] -> [StateIdentifier] -orderStates initial edges = res where - source = Map.singleton initial Set.empty -- ensures that the initial state is in graph even when there are no edges - targets = [ Map.singleton t Set.empty | (_,_,t) <- edges ] - deps = [ Map.singleton f (Set.singleton t) | (_,f,t) <- edges ] - - mp = Map.unionsWith Set.union (source : (targets ++ deps)) - es = [ (f,f,Set.toList ts) | (f,ts) <- Map.toList mp ] - cps = stronglyConnComp es - res = flattenSCCs cps + +-- +-- conventions +-- + +-- type of the state of a node: a closure containing the children states and attributes, +-- with code of type 'type_nt_sem' that represents the subsequent visits to successor states. +type_nt_state nt st = "s_" >|< nt >|< "_" >|< st + +-- type of a visit to a node (the initial, and when in a given state) +-- an instance of this type is called the "semantics" +type_nt_sem_top nt = "t_" >|< nt +type_nt_sem nt st = type_nt_sem_top nt >|< "_s" >|< st + +-- type of a caller (contains visit selection + inputs + continuation) +type_caller nt st = "c_" >|< nt >|< "_s" >|< st + +-- names of records +nm_attach nt = "attach_">|< nt +nm_invoke nt st = "inv_" >|< nt >|< "_s" >|< st + +-- name of the type variable representing the result type of the continuation +cont_tvar = text "'cont__" + + +-- order states in reverse topological order so that successor states are +-- earlier in the resulting list. +orderStates :: StateIdentifier -> [VisitStateState] -> [StateIdentifier] +orderStates initial edges = res where + source = Map.singleton initial Set.empty -- ensures that the initial state is in graph even when there are no edges + targets = [ Map.singleton t Set.empty | (_,_,t) <- edges ] + deps = [ Map.singleton f (Set.singleton t) | (_,f,t) <- edges ] + + mp = Map.unionsWith Set.union (source : (targets ++ deps)) + es = [ (f,f,Set.toList ts) | (f,ts) <- Map.toList mp ] + cps = stronglyConnComp es + res = flattenSCCs cps {-# LINE 179 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 521 "src-ag/ExecutionPlan2Caml.ag" #-} - -type_caller_visit nt v = "c_" >|< nt >|< "_v" >|< v -con_visit nt v = "C_" >|< nt >|< "_v" >|< v - --- field names -nm_inh nt v = "inh_" >|< nt >|< "_v" >|< v -nm_cont nt v = "cont_" >|< nt >|< "_v" >|< v + +type_caller_visit nt v = "c_" >|< nt >|< "_v" >|< v +con_visit nt v = "C_" >|< nt >|< "_v" >|< v + +-- field names +nm_inh nt v = "inh_" >|< nt >|< "_v" >|< v +nm_cont nt v = "cont_" >|< nt >|< "_v" >|< v {-# LINE 189 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 567 "src-ag/ExecutionPlan2Caml.ag" #-} - --- more naming conventions -nm_inarg nm nt v = "i_" >|< nm >|< "_" >|< nt >|< "_v" >|< v -nm_outarg nm nt v = "o_" >|< nm >|< "_" >|< nt >|< "_v" >|< v -nm_outarg_cont = nm_outarg "_cont" - -conNmTVisit nt vId = "t_" >|< nt >|< "_v" >|< vId -conNmTVisitIn nt vId = "t_" >|< nt >|< "_vIn" >|< vId -conNmTVisitOut nt vId = "t_" >|< nt >|< "_vOut" >|< vId - --- todo: remove ppMonadType -ppMonadType :: Options -> PP_Doc -ppMonadType opts - | parallelInvoke opts = text "IO" - | otherwise = text "Identity" + +-- more naming conventions +nm_inarg nm nt v = "i_" >|< nm >|< "_" >|< nt >|< "_v" >|< v +nm_outarg nm nt v = "o_" >|< nm >|< "_" >|< nt >|< "_v" >|< v +nm_outarg_cont = nm_outarg "_cont" + +conNmTVisit nt vId = "t_" >|< nt >|< "_v" >|< vId +conNmTVisitIn nt vId = "t_" >|< nt >|< "_vIn" >|< vId +conNmTVisitOut nt vId = "t_" >|< nt >|< "_vOut" >|< vId + +-- todo: remove ppMonadType +ppMonadType :: Options -> PP_Doc +ppMonadType opts + | parallelInvoke opts = text "IO" + | otherwise = text "Identity" {-# LINE 207 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 780 "src-ag/ExecutionPlan2Caml.ag" #-} - -nm_visit v = "__v" >|< v -nm_k st = "__k" >|< st -nm_st st = "__st" >|< st - -mklets :: (PP b, PP c) => [b] -> c -> PP_Doc -mklets defs body = res where - ppLet def = "let" >#< def >#< "in" - res = vlist (map ppLet defs) >-< body + +nm_visit v = "__v" >|< v +nm_k st = "__k" >|< st +nm_st st = "__st" >|< st + +mklets :: (PP b, PP c) => [b] -> c -> PP_Doc +mklets defs body = res where + ppLet def = "let" >#< def >#< "in" + res = vlist (map ppLet defs) >-< body {-# LINE 219 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 822 "src-ag/ExecutionPlan2Caml.ag" #-} - -resultValName :: String -resultValName = "__result_" - -nextStName :: String -nextStName = "__st_" + +resultValName :: String +resultValName = "__result_" + +nextStName :: String +nextStName = "__st_" {-# LINE 228 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 963 "src-ag/ExecutionPlan2Caml.ag" #-} - -stname :: Identifier -> Int -> String -stname child st = "_" ++ getName child ++ "X" ++ show st - --- should actually return some conversion info -compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool -compatibleAttach _ _ _ = True + +stname :: Identifier -> Int -> String +stname child st = "_" ++ getName child ++ "X" ++ show st + +-- should actually return some conversion info +compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool +compatibleAttach _ _ _ = True {-# LINE 238 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 1030 "src-ag/ExecutionPlan2Caml.ag" #-} - -dummyPat :: Options -> Bool -> PP_Doc -dummyPat opts noArgs - | not noArgs = empty - | strictDummyToken opts = text "()" - | otherwise = text "(_ : unit)" - -dummyArg :: Options -> Bool -> PP_Doc -dummyArg opts noArgs - | not noArgs = empty - | otherwise = text "()" - -dummyType :: Options -> Bool -> PP_Doc -dummyType opts noArgs - | not noArgs = empty - | otherwise = text "unit" + +dummyPat :: Options -> Bool -> PP_Doc +dummyPat opts noArgs + | not noArgs = empty + | strictDummyToken opts = text "()" + | otherwise = text "(_ : unit)" + +dummyArg :: Options -> Bool -> PP_Doc +dummyArg opts noArgs + | not noArgs = empty + | otherwise = text "()" + +dummyType :: Options -> Bool -> PP_Doc +dummyType opts noArgs + | not noArgs = empty + | otherwise = text "unit" {-# LINE 257 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 1106 "src-ag/ExecutionPlan2Caml.ag" #-} - -data NonLocalAttr - = AttrInh Identifier Identifier - | AttrSyn Identifier Identifier deriving Show - -mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr -mkNonLocalAttr True = AttrInh -- True: inherited attr -mkNonLocalAttr False = AttrSyn - -lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs -lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns - --- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that --- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. --- However, for now we simply decide to return Nothing in this case, which skips the type annotation. -lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupType child name attrMp childMp - | noParameters childTp = Just ppDoc - | otherwise = Nothing - where - attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs - childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp - nonterm = extractNonterminal childTp - childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp - ppDoc = ppTp attrTp - -noParameters :: Type -> Bool -noParameters (Haskell _) = True -noParameters (NT _ args _) = null args + +data NonLocalAttr + = AttrInh Identifier Identifier + | AttrSyn Identifier Identifier deriving Show + +mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr +mkNonLocalAttr True = AttrInh -- True: inherited attr +mkNonLocalAttr False = AttrSyn + +lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc +lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs +lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns + +-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that +-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. +-- However, for now we simply decide to return Nothing in this case, which skips the type annotation. +lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc +lookupType child name attrMp childMp + | noParameters childTp = Just ppDoc + | otherwise = Nothing + where + attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs + childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp + nonterm = extractNonterminal childTp + childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp + ppDoc = ppTp attrTp + +noParameters :: Type -> Bool +noParameters (Haskell _) = True +noParameters (NT _ args _) = null args {-# LINE 290 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 1204 "src-ag/ExecutionPlan2Caml.ag" #-} - -contNm = text "__cont_" -inpsNm = text "__inps_" - --- a `compatibleKind` b means: can kind b be invoked from a -compatibleKind :: VisitKind -> VisitKind -> Bool -compatibleKind _ _ = True - -compatibleRule :: VisitKind -> Bool -> Bool -compatibleRule (VisitPure _) False = False -compatibleRule _ _ = True + +contNm = text "__cont_" +inpsNm = text "__inps_" + +-- a `compatibleKind` b means: can kind b be invoked from a +compatibleKind :: VisitKind -> VisitKind -> Bool +compatibleKind _ _ = True + +compatibleRule :: VisitKind -> Bool -> Bool +compatibleRule (VisitPure _) False = False +compatibleRule _ _ = True {-# LINE 304 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 1229 "src-ag/ExecutionPlan2Caml.ag" #-} - -unionWithSum = Map.unionWith (+) + +unionWithSum = Map.unionWith (+) {-# LINE 309 "src-generated/ExecutionPlan2Caml.hs" #-} {-# LINE 1252 "src-ag/ExecutionPlan2Caml.ag" #-} - -uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) -uwSetUnion = Map.unionWith Set.union - -uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) -uwMapUnion = Map.unionWith Map.union + +uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) +uwSetUnion = Map.unionWith Set.union + +uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) +uwMapUnion = Map.unionWith Map.union {-# LINE 318 "src-generated/ExecutionPlan2Caml.hs" #-} -- EChild ------------------------------------------------------ -- wrapper diff --git a/src-generated/ExecutionPlan2Clean.hs b/src-generated/ExecutionPlan2Clean.hs --- a/src-generated/ExecutionPlan2Clean.hs +++ b/src-generated/ExecutionPlan2Clean.hs @@ -3,102 +3,102 @@ module ExecutionPlan2Clean where {-# LINE 2 "src-ag/HsToken.ag" #-} - -import CommonTypes -import UU.Scanner.Position(Pos) + +import CommonTypes +import UU.Scanner.Position(Pos) {-# LINE 10 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 16 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 23 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 2 "src-ag/ExecutionPlan.ag" #-} - --- VisitSyntax.ag imports -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import CommonTypes -import ErrorMessages - -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Map as Map -import Data.Map(Map) + +-- VisitSyntax.ag imports +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes +import ErrorMessages + +import qualified Data.Set as Set +import Data.Set(Set) +import qualified Data.Map as Map +import Data.Map(Map) {-# LINE 37 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 7 "src-ag/ExecutionPlan2Clean.ag" #-} - -import ExecutionPlan -import Pretty -import PPUtil -import Options -import Data.Monoid(mappend,mempty) -import Data.Maybe -import Debug.Trace -import System.IO -import System.Directory -import System.FilePath -import UU.Scanner.Position - -import TokenDef -import HsToken -import ErrorMessages - -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Sequence(Seq) -import qualified Data.Sequence as Seq -import Data.Foldable(toList) + +import ExecutionPlan +import Pretty +import PPUtil +import Options +import Data.Monoid(mappend,mempty) +import Data.Maybe +import Debug.Trace +import System.IO +import System.Directory +import System.FilePath +import UU.Scanner.Position + +import TokenDef +import HsToken +import ErrorMessages + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Sequence(Seq) +import qualified Data.Sequence as Seq +import Data.Foldable(toList) {-# LINE 64 "src-generated/ExecutionPlan2Clean.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 190 "src-ag/ExecutionPlan2Clean.ag" #-} - -classCtxsToDocs :: ClassContext -> [PP_Doc] -classCtxsToDocs = map toDoc where - toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args)) - -classConstrsToDocs :: [Type] -> [PP_Doc] -classConstrsToDocs = map ppTp - -ppClasses :: [PP_Doc] -> PP_Doc -ppClasses [] = empty -ppClasses xs = "|" >#< pp_block "" "" "&" xs - -ppQuants :: [Identifier] -> PP_Doc -ppQuants [] = empty -ppQuants ps = "E." >#< ppSpaced ps >#< ":" + +classCtxsToDocs :: ClassContext -> [PP_Doc] +classCtxsToDocs = map toDoc where + toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args)) + +classConstrsToDocs :: [Type] -> [PP_Doc] +classConstrsToDocs = map ppTp + +ppClasses :: [PP_Doc] -> PP_Doc +ppClasses [] = empty +ppClasses xs = "|" >#< pp_block "" "" "&" xs + +ppQuants :: [Identifier] -> PP_Doc +ppQuants [] = empty +ppQuants ps = "E." >#< ppSpaced ps >#< ":" {-# LINE 83 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 227 "src-ag/ExecutionPlan2Clean.ag" #-} - --- first parameter indicates: generate a record or not -ppConFields :: Bool -> [PP_Doc] -> PP_Doc -ppConFields True flds = ppListSep "{" "}" ", " flds -ppConFields False flds = ppSpaced flds + +-- first parameter indicates: generate a record or not +ppConFields :: Bool -> [PP_Doc] -> PP_Doc +ppConFields True flds = ppListSep "{" "}" ", " flds +ppConFields False flds = ppSpaced flds {-# LINE 91 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 260 "src-ag/ExecutionPlan2Clean.ag" #-} - -ppTp :: Type -> PP_Doc -ppTp = text . typeToHaskellString Nothing [] + +ppTp :: Type -> PP_Doc +ppTp = text . typeToHaskellString Nothing [] {-# LINE 97 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 333 "src-ag/ExecutionPlan2Clean.ag" #-} - -isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool -isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor + +isRecordConstructor :: NontermIdent -> Map NontermIdent ConstructorType -> Bool +isRecordConstructor nt ctm = Map.lookup nt ctm == Just RecordConstructor {-# LINE 103 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 374 "src-ag/ExecutionPlan2Clean.ag" #-} @@ -106,232 +106,232 @@ {-# LINE 107 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 483 "src-ag/ExecutionPlan2Clean.ag" #-} - -conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId -conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId -conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId -conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId - -ppMonadType :: Options -> PP_Doc -ppMonadType opts - | parallelInvoke opts = text "IO" - | otherwise = text "Identity" + +conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId +conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId +conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId +conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId + +ppMonadType :: Options -> PP_Doc +ppMonadType opts + | parallelInvoke opts = text "IO" + | otherwise = text "Identity" {-# LINE 120 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 652 "src-ag/ExecutionPlan2Clean.ag" #-} - -ppDefor :: Type -> PP_Doc -ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args) -ppDefor (Haskell s) = text s + +ppDefor :: Type -> PP_Doc +ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args) +ppDefor (Haskell s) = text s {-# LINE 127 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 756 "src-ag/ExecutionPlan2Clean.ag" #-} - -mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc -mklet prefix defs body = - prefix - >-< indent (length (show prefix)) - ("let" - >-< indent 4 defs - >-< "in" >#< body) + +mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc +mklet prefix defs body = + prefix + >-< indent (length (show prefix)) + ("let" + >-< indent 4 defs + >-< "in" >#< body) {-# LINE 138 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 817 "src-ag/ExecutionPlan2Clean.ag" #-} - -resultValName :: String -resultValName = "ag__result_" - -nextStName :: String -nextStName = "ag__st_" + +resultValName :: String +resultValName = "ag__result_" + +nextStName :: String +nextStName = "ag__st_" {-# LINE 147 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 878 "src-ag/ExecutionPlan2Clean.ag" #-} - -parResultName :: String -parResultName = "__outcome_" - -fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc -fmtDecl declPure fmt decl = case fmt of - FormatLetDecl -> pp decl - FormatLetLine -> "let" >#< decl >#< "in" - FormatDo | declPure -> "let" >#< decl >#< "in" - | otherwise -> pp decl + +parResultName :: String +parResultName = "__outcome_" + +fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc +fmtDecl declPure fmt decl = case fmt of + FormatLetDecl -> pp decl + FormatLetLine -> "let" >#< decl >#< "in" + FormatDo | declPure -> "let" >#< decl >#< "in" + | otherwise -> pp decl {-# LINE 160 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 992 "src-ag/ExecutionPlan2Clean.ag" #-} - -stname :: Identifier -> Int -> String -stname child st = "st_" ++ getName child ++ "X" ++ show st - --- should actually return some conversion info -compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool -compatibleAttach _ _ _ = True - -unMon :: Options -> PP_Doc -unMon options - | parallelInvoke options = text "'System.IO.Unsafe'.unsafePerformIO" -- IO monad - | otherwise = text "'Control.Monad.Identity'.runIdentity" -- identity monad + +stname :: Identifier -> Int -> String +stname child st = "st_" ++ getName child ++ "X" ++ show st + +-- should actually return some conversion info +compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool +compatibleAttach _ _ _ = True + +unMon :: Options -> PP_Doc +unMon options + | parallelInvoke options = text "'System.IO.Unsafe'.unsafePerformIO" -- IO monad + | otherwise = text "'Control.Monad.Identity'.runIdentity" -- identity monad {-# LINE 175 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 1079 "src-ag/ExecutionPlan2Clean.ag" #-} - -dummyPat :: Options -> Bool -> PP_Doc -dummyPat opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = if strictDummyToken opts - then text "Void" - else text "(_)" - | otherwise = let match | strictDummyToken opts = "!_" - | otherwise = "_" - in pp_parens (match >#< "::" >#< dummyType opts noArgs) - where match | strictDummyToken opts = "(!_)" - | otherwise = "_" - -dummyArg :: Options -> Bool -> PP_Doc -dummyArg opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = text "Void" - | otherwise = text "GHC.Prim.realWorld#" - -dummyType :: Options -> Bool -> PP_Doc -dummyType opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = text "Void" - | otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)" + +dummyPat :: Options -> Bool -> PP_Doc +dummyPat opts noArgs + | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples + | tupleAsDummyToken opts = if strictDummyToken opts + then text "Void" + else text "(_)" + | otherwise = let match | strictDummyToken opts = "!_" + | otherwise = "_" + in pp_parens (match >#< "::" >#< dummyType opts noArgs) + where match | strictDummyToken opts = "(!_)" + | otherwise = "_" + +dummyArg :: Options -> Bool -> PP_Doc +dummyArg opts noArgs + | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples + | tupleAsDummyToken opts = text "Void" + | otherwise = text "GHC.Prim.realWorld#" + +dummyType :: Options -> Bool -> PP_Doc +dummyType opts noArgs + | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples + | tupleAsDummyToken opts = text "Void" + | otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)" {-# LINE 202 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 1105 "src-ag/ExecutionPlan2Clean.ag" #-} - --- rules are "deinlined" to prevent needless code duplication. --- if there is only a bit of duplication, we allow ghc to decide if it is worth it. --- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it. -ruleInlineThresholdSoft :: Int -ruleInlineThresholdSoft = 3 - -ruleInlineThresholdHard :: Int -ruleInlineThresholdHard = 5 - -reallyOftenUsedThreshold :: Int -reallyOftenUsedThreshold = 12 + +-- rules are "deinlined" to prevent needless code duplication. +-- if there is only a bit of duplication, we allow ghc to decide if it is worth it. +-- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it. +ruleInlineThresholdSoft :: Int +ruleInlineThresholdSoft = 3 + +ruleInlineThresholdHard :: Int +ruleInlineThresholdHard = 5 + +reallyOftenUsedThreshold :: Int +reallyOftenUsedThreshold = 12 {-# LINE 217 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 1172 "src-ag/ExecutionPlan2Clean.ag" #-} - -data NonLocalAttr - = AttrInh Identifier Identifier - | AttrSyn Identifier Identifier deriving Show - -mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr -mkNonLocalAttr True = AttrInh -- True: inherited attr -mkNonLocalAttr False = AttrSyn - -lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs -lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns - --- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that --- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. --- However, for now we simply decide to return Nothing in this case, which skips the type annotation. -lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupType child name attrMp childMp - | noParameters childTp = Just ppDoc - | otherwise = Nothing - where - attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs - childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp - nonterm = extractNonterminal childTp - childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp - ppDoc = ppTp attrTp - -noParameters :: Type -> Bool -noParameters (Haskell _) = True -noParameters (NT _ args _) = null args + +data NonLocalAttr + = AttrInh Identifier Identifier + | AttrSyn Identifier Identifier deriving Show + +mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr +mkNonLocalAttr True = AttrInh -- True: inherited attr +mkNonLocalAttr False = AttrSyn + +lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc +lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs +lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns + +-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that +-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. +-- However, for now we simply decide to return Nothing in this case, which skips the type annotation. +lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc +lookupType child name attrMp childMp + | noParameters childTp = Just ppDoc + | otherwise = Nothing + where + attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs + childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp + nonterm = extractNonterminal childTp + childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp + ppDoc = ppTp attrTp + +noParameters :: Type -> Bool +noParameters (Haskell _) = True +noParameters (NT _ args _) = null args {-# LINE 250 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 1259 "src-ag/ExecutionPlan2Clean.ag" #-} - --- a `compatibleKind` b means: can kind b be invoked from a -compatibleKind :: VisitKind -> VisitKind -> Bool -compatibleKind _ _ = True - -compatibleRule :: VisitKind -> Bool -> Bool -compatibleRule (VisitPure _) False = False -compatibleRule _ _ = True + +-- a `compatibleKind` b means: can kind b be invoked from a +compatibleKind :: VisitKind -> VisitKind -> Bool +compatibleKind _ _ = True + +compatibleRule :: VisitKind -> Bool -> Bool +compatibleRule (VisitPure _) False = False +compatibleRule _ _ = True {-# LINE 261 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 1281 "src-ag/ExecutionPlan2Clean.ag" #-} - -unionWithSum = Map.unionWith (+) + +unionWithSum = Map.unionWith (+) {-# LINE 266 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 1304 "src-ag/ExecutionPlan2Clean.ag" #-} - -uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) -uwSetUnion = Map.unionWith Set.union - -uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) -uwMapUnion = Map.unionWith Map.union + +uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) +uwSetUnion = Map.unionWith Set.union + +uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) +uwMapUnion = Map.unionWith Map.union {-# LINE 275 "src-generated/ExecutionPlan2Clean.hs" #-} {-# LINE 1499 "src-ag/ExecutionPlan2Clean.ag" #-} - -renderDocs :: [PP_Doc] -> String -renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" - -writeModule :: FilePath -> [PP_Doc] -> IO () -writeModule path docs - = do bExists <- doesFileExist path - if bExists - then do input <- readFile path - seq (length input) (return ()) - if input /= output - then dumpIt - else return () - else dumpIt - where - output = renderDocs docs - dumpIt = writeFile path output - -cleanIclModuleHeader :: Options -> String -> String -cleanIclModuleHeader flags input - = case moduleName flags - of Name nm -> genMod nm - Default -> genMod (defaultModuleName input) - NoName -> "" - where genMod x = "implementation module " ++ x - -cleanDclModuleHeader :: Options -> String -> Maybe String -> String -cleanDclModuleHeader flags input export - = case moduleName flags - of Name nm -> genMod nm - Default -> genMod (defaultModuleName input) - NoName -> "" - where genMod x = "definition module " ++ x ++ genExp export x - genExp Nothing _ = "" - genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")" - -defaultModuleName :: String -> String -defaultModuleName = dropExtension - -mkIclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String -mkIclModuleHeader Nothing defaultName suffix _ _ - = "implementation module " ++ defaultName ++ suffix -mkIclModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports - = "implementation module " ++ name ++ suffix ++ "\n" ++ imports ++ "\n" - -mkDclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String -mkDclModuleHeader Nothing defaultName suffix _ _ - = "definition module " ++ defaultName ++ suffix -mkDclModuleHeader (Just (name, exports, _)) _ suffix addExports replaceExports - = "definition module " ++ name ++ suffix ++ ex ++ "\n" - where - ex = if null exports || (replaceExports && null addExports) - then "" - else if null addExports - then exports - else if replaceExports - then addExports - else exports ++ "," ++ addExports + +renderDocs :: [PP_Doc] -> String +renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" + +writeModule :: FilePath -> [PP_Doc] -> IO () +writeModule path docs + = do bExists <- doesFileExist path + if bExists + then do input <- readFile path + seq (length input) (return ()) + if input /= output + then dumpIt + else return () + else dumpIt + where + output = renderDocs docs + dumpIt = writeFile path output + +cleanIclModuleHeader :: Options -> String -> String +cleanIclModuleHeader flags input + = case moduleName flags + of Name nm -> genMod nm + Default -> genMod (defaultModuleName input) + NoName -> "" + where genMod x = "implementation module " ++ x + +cleanDclModuleHeader :: Options -> String -> Maybe String -> String +cleanDclModuleHeader flags input export + = case moduleName flags + of Name nm -> genMod nm + Default -> genMod (defaultModuleName input) + NoName -> "" + where genMod x = "definition module " ++ x ++ genExp export x + genExp Nothing _ = "" + genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")" + +defaultModuleName :: String -> String +defaultModuleName = dropExtension + +mkIclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String +mkIclModuleHeader Nothing defaultName suffix _ _ + = "implementation module " ++ defaultName ++ suffix +mkIclModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports + = "implementation module " ++ name ++ suffix ++ "\n" ++ imports ++ "\n" + +mkDclModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String +mkDclModuleHeader Nothing defaultName suffix _ _ + = "definition module " ++ defaultName ++ suffix +mkDclModuleHeader (Just (name, exports, _)) _ suffix addExports replaceExports + = "definition module " ++ name ++ suffix ++ ex ++ "\n" + where + ex = if null exports || (replaceExports && null addExports) + then "" + else if null addExports + then exports + else if replaceExports + then addExports + else exports ++ "," ++ addExports {-# LINE 336 "src-generated/ExecutionPlan2Clean.hs" #-} -- EChild ------------------------------------------------------ -- wrapper diff --git a/src-generated/ExecutionPlan2Hs.hs b/src-generated/ExecutionPlan2Hs.hs --- a/src-generated/ExecutionPlan2Hs.hs +++ b/src-generated/ExecutionPlan2Hs.hs @@ -3,96 +3,96 @@ module ExecutionPlan2Hs where {-# LINE 2 "src-ag/HsToken.ag" #-} - -import CommonTypes -import UU.Scanner.Position(Pos) + +import CommonTypes +import UU.Scanner.Position(Pos) {-# LINE 10 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 16 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 23 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 2 "src-ag/ExecutionPlan.ag" #-} - --- VisitSyntax.ag imports -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import CommonTypes -import ErrorMessages - -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Map as Map -import Data.Map(Map) + +-- VisitSyntax.ag imports +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import CommonTypes +import ErrorMessages + +import qualified Data.Set as Set +import Data.Set(Set) +import qualified Data.Map as Map +import Data.Map(Map) {-# LINE 37 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 7 "src-ag/ExecutionPlan2Hs.ag" #-} - -import ExecutionPlan -import Pretty -import PPUtil -import Options -import Data.Monoid(mappend,mempty) -import Data.Maybe -import Debug.Trace -import System.IO -import System.Directory -import System.FilePath -import UU.Scanner.Position - -import TokenDef -import HsToken -import ErrorMessages - -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Sequence(Seq) -import qualified Data.Sequence as Seq -import Data.Foldable(toList) + +import ExecutionPlan +import Pretty +import PPUtil +import Options +import Data.Monoid(mappend,mempty) +import Data.Maybe +import Debug.Trace +import System.IO +import System.Directory +import System.FilePath +import UU.Scanner.Position + +import TokenDef +import HsToken +import ErrorMessages + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Sequence(Seq) +import qualified Data.Sequence as Seq +import Data.Foldable(toList) {-# LINE 64 "src-generated/ExecutionPlan2Hs.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 163 "src-ag/ExecutionPlan2Hs.ag" #-} - -classCtxsToDocs :: ClassContext -> [PP_Doc] -classCtxsToDocs = map toDoc where - toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args)) - -classConstrsToDocs :: [Type] -> [PP_Doc] -classConstrsToDocs = map ppTp - -ppClasses :: [PP_Doc] -> PP_Doc -ppClasses [] = empty -ppClasses xs = pp_block "(" ")" "," xs >#< "=>" - -ppQuants :: [Identifier] -> PP_Doc -ppQuants [] = empty -ppQuants ps = "forall" >#< ppSpaced ps >#< "." + +classCtxsToDocs :: ClassContext -> [PP_Doc] +classCtxsToDocs = map toDoc where + toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args)) + +classConstrsToDocs :: [Type] -> [PP_Doc] +classConstrsToDocs = map ppTp + +ppClasses :: [PP_Doc] -> PP_Doc +ppClasses [] = empty +ppClasses xs = pp_block "(" ")" "," xs >#< "=>" + +ppQuants :: [Identifier] -> PP_Doc +ppQuants [] = empty +ppQuants ps = "forall" >#< ppSpaced ps >#< "." {-# LINE 83 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 192 "src-ag/ExecutionPlan2Hs.ag" #-} - --- first parameter indicates: generate a record or not -ppConFields :: Bool -> [PP_Doc] -> PP_Doc -ppConFields True flds = ppListSep "{" "}" ", " $ filter (not . isEmpty) flds -ppConFields False flds = ppSpaced flds + +-- first parameter indicates: generate a record or not +ppConFields :: Bool -> [PP_Doc] -> PP_Doc +ppConFields True flds = ppListSep "{" "}" ", " $ filter (not . isEmpty) flds +ppConFields False flds = ppSpaced flds {-# LINE 91 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 218 "src-ag/ExecutionPlan2Hs.ag" #-} - -ppTp :: Type -> PP_Doc -ppTp = text . typeToHaskellString Nothing [] + +ppTp :: Type -> PP_Doc +ppTp = text . typeToHaskellString Nothing [] {-# LINE 97 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 332 "src-ag/ExecutionPlan2Hs.ag" #-} @@ -100,231 +100,231 @@ {-# LINE 101 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 428 "src-ag/ExecutionPlan2Hs.ag" #-} - -conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId -conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId -conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId -conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId - -ppMonadType :: Options -> PP_Doc -ppMonadType opts - | parallelInvoke opts = text "IO" - | otherwise = text "Identity" + +conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId +conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId +conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId +conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId + +ppMonadType :: Options -> PP_Doc +ppMonadType opts + | parallelInvoke opts = text "IO" + | otherwise = text "Identity" {-# LINE 114 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 589 "src-ag/ExecutionPlan2Hs.ag" #-} - -ppDefor :: Type -> PP_Doc -ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args) -ppDefor (Haskell s) = text s + +ppDefor :: Type -> PP_Doc +ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args) +ppDefor (Haskell s) = text s {-# LINE 121 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 713 "src-ag/ExecutionPlan2Hs.ag" #-} - -mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc -mklet prefix defs body = - prefix >#< "let" - >-< indent 3 defs - >-< indent 2 "in" >#< body + +mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc +mklet prefix defs body = + prefix >#< "let" + >-< indent 3 defs + >-< indent 2 "in" >#< body {-# LINE 130 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 779 "src-ag/ExecutionPlan2Hs.ag" #-} - -resultValName :: String -resultValName = "__result_" - -nextStName :: String -nextStName = "__st_" + +resultValName :: String +resultValName = "__result_" + +nextStName :: String +nextStName = "__st_" {-# LINE 139 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 850 "src-ag/ExecutionPlan2Hs.ag" #-} - -parResultName :: String -parResultName = "__outcome_" - -fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc -fmtDecl declPure fmt decl = case fmt of - FormatLetDecl -> pp decl - FormatLetLine -> "let" >#< decl >#< "in" - FormatDo | declPure -> "let" >#< decl - | otherwise -> pp decl + +parResultName :: String +parResultName = "__outcome_" + +fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc +fmtDecl declPure fmt decl = case fmt of + FormatLetDecl -> pp decl + FormatLetLine -> "let" >#< decl >#< "in" + FormatDo | declPure -> "let" >#< decl + | otherwise -> pp decl {-# LINE 152 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 976 "src-ag/ExecutionPlan2Hs.ag" #-} - -stname :: Identifier -> Int -> String -stname child st = "_" ++ getName child ++ "X" ++ show st - --- should actually return some conversion info -compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool -compatibleAttach _ _ _ = True - -unMon :: Options -> PP_Doc -unMon options - | parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO" -- IO monad - | otherwise = text "Control.Monad.Identity.runIdentity" -- identity monad + +stname :: Identifier -> Int -> String +stname child st = "_" ++ getName child ++ "X" ++ show st + +-- should actually return some conversion info +compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool +compatibleAttach _ _ _ = True + +unMon :: Options -> PP_Doc +unMon options + | parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO" -- IO monad + | otherwise = text "Control.Monad.Identity.runIdentity" -- identity monad {-# LINE 167 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 1084 "src-ag/ExecutionPlan2Hs.ag" #-} - -dummyPat :: Options -> Bool -> PP_Doc -dummyPat opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = if strictDummyToken opts - then text "()" - else text "(_ :: ())" - | otherwise = let match | strictDummyToken opts = "!_" - | otherwise = "_" - in pp_parens (match >#< "::" >#< dummyType opts noArgs) - where match | strictDummyToken opts = "(!_)" - | otherwise = "_" - -dummyArg :: Options -> Bool -> PP_Doc -dummyArg opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = text "()" - | otherwise = text "GHC.Prim.realWorld#" - -dummyType :: Options -> Bool -> PP_Doc -dummyType opts noArgs - | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples - | tupleAsDummyToken opts = text "()" - | otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)" + +dummyPat :: Options -> Bool -> PP_Doc +dummyPat opts noArgs + | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples + | tupleAsDummyToken opts = if strictDummyToken opts + then text "()" + else text "(_ :: ())" + | otherwise = let match | strictDummyToken opts = "!_" + | otherwise = "_" + in pp_parens (match >#< "::" >#< dummyType opts noArgs) + where match | strictDummyToken opts = "(!_)" + | otherwise = "_" + +dummyArg :: Options -> Bool -> PP_Doc +dummyArg opts noArgs + | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples + | tupleAsDummyToken opts = text "()" + | otherwise = text "GHC.Prim.realWorld#" + +dummyType :: Options -> Bool -> PP_Doc +dummyType opts noArgs + | not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples + | tupleAsDummyToken opts = text "()" + | otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)" {-# LINE 194 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 1110 "src-ag/ExecutionPlan2Hs.ag" #-} - --- rules are "deinlined" to prevent needless code duplication. --- if there is only a bit of duplication, we allow ghc to decide if it is worth it. --- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it. -ruleInlineThresholdSoft :: Int -ruleInlineThresholdSoft = 3 - -ruleInlineThresholdHard :: Int -ruleInlineThresholdHard = 5 - -reallyOftenUsedThreshold :: Int -reallyOftenUsedThreshold = 12 + +-- rules are "deinlined" to prevent needless code duplication. +-- if there is only a bit of duplication, we allow ghc to decide if it is worth it. +-- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it. +ruleInlineThresholdSoft :: Int +ruleInlineThresholdSoft = 3 + +ruleInlineThresholdHard :: Int +ruleInlineThresholdHard = 5 + +reallyOftenUsedThreshold :: Int +reallyOftenUsedThreshold = 12 {-# LINE 209 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 1176 "src-ag/ExecutionPlan2Hs.ag" #-} - -data NonLocalAttr - = AttrInh Identifier Identifier - | AttrSyn Identifier Identifier deriving Show - -mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr -mkNonLocalAttr True = AttrInh -- True: inherited attr -mkNonLocalAttr False = AttrSyn - -lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs -lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns - --- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that --- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. --- However, for now we simply decide to return Nothing in this case, which skips the type annotation. -lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc -lookupType child name attrMp childMp - | noParameters childTp = Just ppDoc - | otherwise = Nothing - where - attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs - childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp - nonterm = extractNonterminal childTp - childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp - ppDoc = ppTp attrTp - -noParameters :: Type -> Bool -noParameters (Haskell _) = True -noParameters (NT _ args _) = null args + +data NonLocalAttr + = AttrInh Identifier Identifier + | AttrSyn Identifier Identifier deriving Show + +mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr +mkNonLocalAttr True = AttrInh -- True: inherited attr +mkNonLocalAttr False = AttrSyn + +lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc +lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs +lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns + +-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that +-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child. +-- However, for now we simply decide to return Nothing in this case, which skips the type annotation. +lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc +lookupType child name attrMp childMp + | noParameters childTp = Just ppDoc + | otherwise = Nothing + where + attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs + childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp + nonterm = extractNonterminal childTp + childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp + ppDoc = ppTp attrTp + +noParameters :: Type -> Bool +noParameters (Haskell _) = True +noParameters (NT _ args _) = null args {-# LINE 242 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 1263 "src-ag/ExecutionPlan2Hs.ag" #-} - --- a `compatibleKind` b means: can kind b be invoked from a -compatibleKind :: VisitKind -> VisitKind -> Bool -compatibleKind _ _ = True - -compatibleRule :: VisitKind -> Bool -> Bool -compatibleRule (VisitPure _) False = False -compatibleRule _ _ = True + +-- a `compatibleKind` b means: can kind b be invoked from a +compatibleKind :: VisitKind -> VisitKind -> Bool +compatibleKind _ _ = True + +compatibleRule :: VisitKind -> Bool -> Bool +compatibleRule (VisitPure _) False = False +compatibleRule _ _ = True {-# LINE 253 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 1285 "src-ag/ExecutionPlan2Hs.ag" #-} - -unionWithSum = Map.unionWith (+) + +unionWithSum = Map.unionWith (+) {-# LINE 258 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 1308 "src-ag/ExecutionPlan2Hs.ag" #-} - -uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) -uwSetUnion = Map.unionWith Set.union - -uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) -uwMapUnion = Map.unionWith Map.union + +uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b) +uwSetUnion = Map.unionWith Set.union + +uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c) +uwMapUnion = Map.unionWith Map.union {-# LINE 267 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 1525 "src-ag/ExecutionPlan2Hs.ag" #-} - -renderDocs :: [PP_Doc] -> String -renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" - -writeModule :: FilePath -> [PP_Doc] -> IO () -writeModule path docs - = do bExists <- doesFileExist path - if bExists - then do input <- readFile path - seq (length input) (return ()) - if input /= output - then dumpIt - else return () - else dumpIt - where - output = renderDocs docs - dumpIt = writeFile path output + +renderDocs :: [PP_Doc] -> String +renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" + +writeModule :: FilePath -> [PP_Doc] -> IO () +writeModule path docs + = do bExists <- doesFileExist path + if bExists + then do input <- readFile path + seq (length input) (return ()) + if input /= output + then dumpIt + else return () + else dumpIt + where + output = renderDocs docs + dumpIt = writeFile path output {-# LINE 287 "src-generated/ExecutionPlan2Hs.hs" #-} {-# LINE 1672 "src-ag/ExecutionPlan2Hs.ag" #-} - -ppNoInline :: PP a => a -> PP_Doc -ppNoInline = ppPragmaBinding "NOINLINE" - -ppInline :: PP a => a -> PP_Doc -ppInline = ppPragmaBinding "INLINE" - -ppInlinable :: PP a => a -> PP_Doc -ppInlinable = ppPragmaBinding "INLINABLE" - -ppPragmaBinding :: (PP a, PP b) => a -> b -> PP_Doc -ppPragmaBinding pragma nm = "{-#" >#< pragma >#< nm >#< "#-}" - -ppCostCentre :: PP a => a -> PP_Doc -ppCostCentre nm = "{-#" >#< "SCC" >#< "\"" >|< nm >|< "\"" >#< "#-}" - -warrenFlagsPP :: Options -> PP_Doc -warrenFlagsPP options = vlist - [ pp "{-# LANGUAGE Rank2Types, GADTs #-}" - , if bangpats options - then pp "{-# LANGUAGE BangPatterns #-}" - else empty - , if noPerRuleTypeSigs options && noPerStateTypeSigs options - then empty - else pp "{-# LANGUAGE ScopedTypeVariables #-}" - , if tupleAsDummyToken options - then empty - else pp "{-# LANGUAGE ScopedTypeVariables, MagicHash #-}" - , -- not that the meaning of "unbox" is here that strict fields in data types may be - -- unboxed if possible. This may affect user-defined data types declared in the module. - -- Unfortunately, we cannot turn it on for only the AG generated data types without - -- causing a zillion of warnings. - if unbox options && bangpats options - then pp $ "{-# OPTIONS_GHC -funbox-strict-fields -fstrictness #-}" - else empty - , if parallelInvoke options && not (noEagerBlackholing options) - then pp $ "{-# OPTIONS_GHC -feager-blackholing #-}" - else empty - ] + +ppNoInline :: PP a => a -> PP_Doc +ppNoInline = ppPragmaBinding "NOINLINE" + +ppInline :: PP a => a -> PP_Doc +ppInline = ppPragmaBinding "INLINE" + +ppInlinable :: PP a => a -> PP_Doc +ppInlinable = ppPragmaBinding "INLINABLE" + +ppPragmaBinding :: (PP a, PP b) => a -> b -> PP_Doc +ppPragmaBinding pragma nm = "{-#" >#< pragma >#< nm >#< "#-}" + +ppCostCentre :: PP a => a -> PP_Doc +ppCostCentre nm = "{-#" >#< "SCC" >#< "\"" >|< nm >|< "\"" >#< "#-}" + +warrenFlagsPP :: Options -> PP_Doc +warrenFlagsPP options = vlist + [ pp "{-# LANGUAGE Rank2Types, GADTs #-}" + , if bangpats options + then pp "{-# LANGUAGE BangPatterns #-}" + else empty + , if noPerRuleTypeSigs options && noPerStateTypeSigs options + then empty + else pp "{-# LANGUAGE ScopedTypeVariables #-}" + , if tupleAsDummyToken options + then empty + else pp "{-# LANGUAGE ScopedTypeVariables, MagicHash #-}" + , -- not that the meaning of "unbox" is here that strict fields in data types may be + -- unboxed if possible. This may affect user-defined data types declared in the module. + -- Unfortunately, we cannot turn it on for only the AG generated data types without + -- causing a zillion of warnings. + if unbox options && bangpats options + then pp $ "{-# OPTIONS_GHC -funbox-strict-fields -fstrictness #-}" + else empty + , if parallelInvoke options && not (noEagerBlackholing options) + then pp $ "{-# OPTIONS_GHC -feager-blackholing #-}" + else empty + ] {-# LINE 329 "src-generated/ExecutionPlan2Hs.hs" #-} -- EChild ------------------------------------------------------ -- wrapper diff --git a/src-generated/Expression.hs b/src-generated/Expression.hs --- a/src-generated/Expression.hs +++ b/src-generated/Expression.hs @@ -3,9 +3,9 @@ -- UUAGC 0.9.53 (src-ag/Expression.ag) module Expression where {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 10 "src-generated/Expression.hs" #-} -- Expression -------------------------------------------------- {- diff --git a/src-generated/GenerateCode.hs b/src-generated/GenerateCode.hs --- a/src-generated/GenerateCode.hs +++ b/src-generated/GenerateCode.hs @@ -3,265 +3,265 @@ module GenerateCode where {-# LINE 2 "src-ag/DeclBlocks.ag" #-} - -import Code (Decl,Expr) + +import Code (Decl,Expr) {-# LINE 9 "src-generated/GenerateCode.hs" #-} {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 16 "src-generated/GenerateCode.hs" #-} {-# LINE 2 "src-ag/CodeSyntax.ag" #-} - -import Patterns -import CommonTypes -import Data.Map(Map) -import Data.Set(Set) + +import Patterns +import CommonTypes +import Data.Map(Map) +import Data.Set(Set) {-# LINE 24 "src-generated/GenerateCode.hs" #-} {-# LINE 9 "src-ag/GenerateCode.ag" #-} - -import CommonTypes -import SequentialTypes -import Code hiding (Type) -import qualified Code -import Options -import CodeSyntax -import ErrorMessages -import GrammarInfo -import DeclBlocks - -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq) -import UU.Scanner.Position -import TokenDef -import HsToken -import HsTokenScanner - -import Data.List(partition,intersperse) -import Data.Maybe(fromJust,isJust) - + +import CommonTypes +import SequentialTypes +import Code hiding (Type) +import qualified Code +import Options +import CodeSyntax +import ErrorMessages +import GrammarInfo +import DeclBlocks + +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Set as Set +import Data.Set(Set) +import qualified Data.Sequence as Seq +import Data.Sequence(Seq) +import UU.Scanner.Position +import TokenDef +import HsToken +import HsTokenScanner + +import Data.List(partition,intersperse) +import Data.Maybe(fromJust,isJust) + {-# LINE 52 "src-generated/GenerateCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 107 "src-ag/GenerateCode.ag" #-} - --- remove possible @v references in the types of a data type. -cleanupArg :: Options -> String -> String -cleanupArg opts s - = case idEvalType opts (SimpleType s) of - SimpleType s' -> s' - _ -> error "Only SimpleType supported" + +-- remove possible @v references in the types of a data type. +cleanupArg :: Options -> String -> String +cleanupArg opts s + = case idEvalType opts (SimpleType s) of + SimpleType s' -> s' + _ -> error "Only SimpleType supported" {-# LINE 63 "src-generated/GenerateCode.hs" #-} {-# LINE 123 "src-ag/GenerateCode.ag" #-} - -appContext :: ContextMap -> NontermIdent -> Code.Type -> Code.Type -appContext mp nt tp - = maybe tp (\ctx -> CtxApp (map (\(n,ns) -> (getName n, ns)) ctx) tp) $ Map.lookup nt mp - -appQuant :: QuantMap -> NontermIdent -> Code.Type -> Code.Type -appQuant mp nt tp - = foldr QuantApp tp $ Map.findWithDefault [] nt mp + +appContext :: ContextMap -> NontermIdent -> Code.Type -> Code.Type +appContext mp nt tp + = maybe tp (\ctx -> CtxApp (map (\(n,ns) -> (getName n, ns)) ctx) tp) $ Map.lookup nt mp + +appQuant :: QuantMap -> NontermIdent -> Code.Type -> Code.Type +appQuant mp nt tp + = foldr QuantApp tp $ Map.findWithDefault [] nt mp {-# LINE 74 "src-generated/GenerateCode.hs" #-} {-# LINE 249 "src-ag/GenerateCode.ag" #-} - -mkDecl :: Bool -> Lhs -> Expr -> Set String -> Set String -> Decl -mkDecl True lhs rhs _ _ = Bind lhs rhs -mkDecl False lhs rhs s1 s2 = Decl lhs rhs s1 s2 - -unwrapSem :: Bool -> NontermIdent -> Expr -> Expr -unwrapSem False _ e = e -unwrapSem True nm e = Case e alts - where alts = [CaseAlt left right] - left = Fun (typeName nm 0) [SimpleExpr "x"] - right = SimpleExpr "x" + +mkDecl :: Bool -> Lhs -> Expr -> Set String -> Set String -> Decl +mkDecl True lhs rhs _ _ = Bind lhs rhs +mkDecl False lhs rhs s1 s2 = Decl lhs rhs s1 s2 + +unwrapSem :: Bool -> NontermIdent -> Expr -> Expr +unwrapSem False _ e = e +unwrapSem True nm e = Case e alts + where alts = [CaseAlt left right] + left = Fun (typeName nm 0) [SimpleExpr "x"] + right = SimpleExpr "x" {-# LINE 88 "src-generated/GenerateCode.hs" #-} {-# LINE 545 "src-ag/GenerateCode.ag" #-} - -mkLambdaArg :: String -> Maybe Code.Type -> Expr -mkLambdaArg nm Nothing = SimpleExpr nm -mkLambdaArg nm (Just tp) = TypedExpr (SimpleExpr nm) tp - -mkLambda :: Exprs -> Expr -> Expr -mkLambda [] e = e -mkLambda xs e = Lambda xs e - -mkSemFun :: Identifier -> Int -> Exprs -> Expr -> Expr -mkSemFun nt nr xs e = SemFun (typeName nt nr) xs e - -typeAppStrs :: String -> [String] -> Code.Type -typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params) - -isHigherOrder :: ChildKind -> Bool -isHigherOrder ChildAttr = True -isHigherOrder _ = False - -pickOrigType :: (Identifier, Type, ChildKind) -> (Identifier, Type, ChildKind) -pickOrigType (nm, _, virt@(ChildReplace x)) = (nm, x, virt) -pickOrigType x = x + +mkLambdaArg :: String -> Maybe Code.Type -> Expr +mkLambdaArg nm Nothing = SimpleExpr nm +mkLambdaArg nm (Just tp) = TypedExpr (SimpleExpr nm) tp + +mkLambda :: Exprs -> Expr -> Expr +mkLambda [] e = e +mkLambda xs e = Lambda xs e + +mkSemFun :: Identifier -> Int -> Exprs -> Expr -> Expr +mkSemFun nt nr xs e = SemFun (typeName nt nr) xs e + +typeAppStrs :: String -> [String] -> Code.Type +typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params) + +isHigherOrder :: ChildKind -> Bool +isHigherOrder ChildAttr = True +isHigherOrder _ = False + +pickOrigType :: (Identifier, Type, ChildKind) -> (Identifier, Type, ChildKind) +pickOrigType (nm, _, virt@(ChildReplace x)) = (nm, x, virt) +pickOrigType x = x {-# LINE 113 "src-generated/GenerateCode.hs" #-} {-# LINE 642 "src-ag/GenerateCode.ag" #-} - -mkPartitionedFunction :: String -> Bool -> [Decl] -> [String] -> DeclBlocks -> ([Decl], Expr) -mkPartitionedFunction prefix' optCase nextVisitDecls lastExprVars cpsTree - = let inh = Inh_DeclBlocksRoot { prefix_Inh_DeclBlocksRoot = prefix' - , optCase_Inh_DeclBlocksRoot = optCase - , nextVisitDecls_Inh_DeclBlocksRoot = nextVisitDecls - , lastExprVars_Inh_DeclBlocksRoot = lastExprVars - } - sem = sem_DeclBlocksRoot (DeclBlocksRoot cpsTree) - syn = wrap_DeclBlocksRoot sem inh - in (lambdas_Syn_DeclBlocksRoot syn, firstCall_Syn_DeclBlocksRoot syn) + +mkPartitionedFunction :: String -> Bool -> [Decl] -> [String] -> DeclBlocks -> ([Decl], Expr) +mkPartitionedFunction prefix' optCase nextVisitDecls lastExprVars cpsTree + = let inh = Inh_DeclBlocksRoot { prefix_Inh_DeclBlocksRoot = prefix' + , optCase_Inh_DeclBlocksRoot = optCase + , nextVisitDecls_Inh_DeclBlocksRoot = nextVisitDecls + , lastExprVars_Inh_DeclBlocksRoot = lastExprVars + } + sem = sem_DeclBlocksRoot (DeclBlocksRoot cpsTree) + syn = wrap_DeclBlocksRoot sem inh + in (lambdas_Syn_DeclBlocksRoot syn, firstCall_Syn_DeclBlocksRoot syn) {-# LINE 127 "src-generated/GenerateCode.hs" #-} {-# LINE 692 "src-ag/GenerateCode.ag" #-} - -freevars :: [String] -> [Decl] -> [String] -freevars additional decls - = Set.toList (allused `Set.difference` alldefined) - where - allused = Set.unions (Set.fromList additional : map usedvars decls) - alldefined = Set.unions (map definedvars decls) - - usedvars (Decl _ _ _ uses) = uses - usedvars _ = Set.empty - - definedvars (Decl _ _ defs _) = defs - definedvars _ = Set.empty - -mkBlockLambda :: Bool -> String -> [String] -> [Decl] -> Expr -> Decl -mkBlockLambda optCase name args decls expr - = Decl lhs rhs Set.empty Set.empty - where - lhs = Fun name (map SimpleExpr args) - rhs = mkLet optCase decls expr + +freevars :: [String] -> [Decl] -> [String] +freevars additional decls + = Set.toList (allused `Set.difference` alldefined) + where + allused = Set.unions (Set.fromList additional : map usedvars decls) + alldefined = Set.unions (map definedvars decls) + + usedvars (Decl _ _ _ uses) = uses + usedvars _ = Set.empty + + definedvars (Decl _ _ defs _) = defs + definedvars _ = Set.empty + +mkBlockLambda :: Bool -> String -> [String] -> [Decl] -> Expr -> Decl +mkBlockLambda optCase name args decls expr + = Decl lhs rhs Set.empty Set.empty + where + lhs = Fun name (map SimpleExpr args) + rhs = mkLet optCase decls expr {-# LINE 150 "src-generated/GenerateCode.hs" #-} {-# LINE 770 "src-ag/GenerateCode.ag" #-} - -typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type -typeToCodeType _ _ tp - = case tp of - NT nt tps defor -> NontermType (getName nt) tps defor - Haskell t -> SimpleType t - Self -> error "Self type not allowed here." - -evalType :: Options -> (String -> String) -> Code.Type -> Code.Type -evalType opts replf t' - = chase t' - where - chase t - = case t of - Arr l r -> Arr (chase l) (chase r) - TypeApp f as -> TypeApp (chase f) (map chase as) - TupleType tps -> TupleType (map chase tps) - UnboxedTupleType tps -> UnboxedTupleType (map chase tps) - Code.List tp -> Code.List (chase tp) - SimpleType txt -> let tks = lexTokens opts (initPos txt) txt - tks' = map replaceTok tks - txt' = unlines . showTokens . tokensToStrings $ tks' - in SimpleType txt' - TMaybe m -> TMaybe (chase m) - TEither l r -> TEither (chase l) (chase r) - TMap k v -> TMap (chase k) (chase v) - TIntMap v -> TIntMap (chase v) - TSet m -> TSet (chase m) - _ -> t - - replaceTok t - = case t of - AGLocal v p _ -> HsToken (replf $ getName v) p - _ -> t - -idEvalType :: Options -> Code.Type -> Code.Type -idEvalType options = evalType options id + +typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type +typeToCodeType _ _ tp + = case tp of + NT nt tps defor -> NontermType (getName nt) tps defor + Haskell t -> SimpleType t + Self -> error "Self type not allowed here." + +evalType :: Options -> (String -> String) -> Code.Type -> Code.Type +evalType opts replf t' + = chase t' + where + chase t + = case t of + Arr l r -> Arr (chase l) (chase r) + TypeApp f as -> TypeApp (chase f) (map chase as) + TupleType tps -> TupleType (map chase tps) + UnboxedTupleType tps -> UnboxedTupleType (map chase tps) + Code.List tp -> Code.List (chase tp) + SimpleType txt -> let tks = lexTokens opts (initPos txt) txt + tks' = map replaceTok tks + txt' = unlines . showTokens . tokensToStrings $ tks' + in SimpleType txt' + TMaybe m -> TMaybe (chase m) + TEither l r -> TEither (chase l) (chase r) + TMap k v -> TMap (chase k) (chase v) + TIntMap v -> TIntMap (chase v) + TSet m -> TSet (chase m) + _ -> t + + replaceTok t + = case t of + AGLocal v p _ -> HsToken (replf $ getName v) p + _ -> t + +idEvalType :: Options -> Code.Type -> Code.Type +idEvalType options = evalType options id {-# LINE 190 "src-generated/GenerateCode.hs" #-} {-# LINE 896 "src-ag/GenerateCode.ag" #-} - --- for a virtual child that already existed as a child, returns -isFirstOrder :: ChildKind -> Type -> Maybe Type -isFirstOrder ChildSyntax tp = Just tp -isFirstOrder ChildAttr _ = Nothing -isFirstOrder (ChildReplace tp) _ = Just tp + +-- for a virtual child that already existed as a child, returns +isFirstOrder :: ChildKind -> Type -> Maybe Type +isFirstOrder ChildSyntax tp = Just tp +isFirstOrder ChildAttr _ = Nothing +isFirstOrder (ChildReplace tp) _ = Just tp {-# LINE 199 "src-generated/GenerateCode.hs" #-} {-# LINE 917 "src-ag/GenerateCode.ag" #-} - -makeLocalComment :: Int -> String -> Identifier -> Maybe Type -> String -makeLocalComment width what name tp = let x = getName name - y = maybe "_" (\t -> case t of - (NT nt tps _) -> getName nt ++ " " ++ unwords tps - Haskell t' -> '{' : t' ++ "}" - Self -> error "Self type not allowed here.") tp - in ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y ) - + +makeLocalComment :: Int -> String -> Identifier -> Maybe Type -> String +makeLocalComment width what name tp = let x = getName name + y = maybe "_" (\t -> case t of + (NT nt tps _) -> getName nt ++ " " ++ unwords tps + Haskell t' -> '{' : t' ++ "}" + Self -> error "Self type not allowed here.") tp + in ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y ) + {-# LINE 211 "src-generated/GenerateCode.hs" #-} {-# LINE 951 "src-ag/GenerateCode.ag" #-} - --- Lets or nested Cases? --- or even a do-expression? - -data DeclsType = DeclsLet | DeclsCase | DeclsDo - -mkDecls :: DeclsType -> Decls -> Expr -> Expr -mkDecls DeclsLet = mkLet False -mkDecls DeclsCase = mkLet True -mkDecls DeclsDo = \decls -> Do (map toBind decls) - where toBind (Decl lhs rhs _ _) = BindLet lhs rhs - toBind d = d - -mkLet :: Bool -> Decls -> Expr -> Expr -mkLet False decls body = Let decls body -mkLet True decls body = foldr oneCase body decls - -oneCase :: Decl -> Expr -> Expr -oneCase (Decl left rhs _ _) ex = Case rhs [CaseAlt left ex] -oneCase (Resume _ nt left rhs) ex = ResumeExpr nt rhs left ex -oneCase _ ex = ex - --- Gives the name of the visit function -funname :: Show a => a -> Int -> String -funname field 0 = show field ++ "_" -funname field nr = show field ++ "_" ++ show nr - --- Gives the name of a semantic function -seqSemname :: String -> NontermIdent -> ConstructorIdent -> Int -> String -seqSemname pre nt con 0 = semname pre nt con -seqSemname pre nt con nr = semname pre nt con ++ "_" ++ show nr - --- Gives the name of a type -typeName :: NontermIdent -> Int -> String -typeName nt 0 = "T_" ++ show nt -typeName nt n = "T_" ++ show nt ++ "_" ++ show n - -ntOfVisit :: NontermIdent -> Int -> NontermIdent -ntOfVisit nt 0 = nt -ntOfVisit nt n = Ident (show nt ++ "_" ++ show n) (getPos nt) - --- Gives the name of a visit function -visitname :: String -> NontermIdent -> Int -> String -visitname pre nt n = pre ++ getName nt ++ "_" ++ show n + +-- Lets or nested Cases? +-- or even a do-expression? + +data DeclsType = DeclsLet | DeclsCase | DeclsDo + +mkDecls :: DeclsType -> Decls -> Expr -> Expr +mkDecls DeclsLet = mkLet False +mkDecls DeclsCase = mkLet True +mkDecls DeclsDo = \decls -> Do (map toBind decls) + where toBind (Decl lhs rhs _ _) = BindLet lhs rhs + toBind d = d + +mkLet :: Bool -> Decls -> Expr -> Expr +mkLet False decls body = Let decls body +mkLet True decls body = foldr oneCase body decls + +oneCase :: Decl -> Expr -> Expr +oneCase (Decl left rhs _ _) ex = Case rhs [CaseAlt left ex] +oneCase (Resume _ nt left rhs) ex = ResumeExpr nt rhs left ex +oneCase _ ex = ex + +-- Gives the name of the visit function +funname :: Show a => a -> Int -> String +funname field 0 = show field ++ "_" +funname field nr = show field ++ "_" ++ show nr + +-- Gives the name of a semantic function +seqSemname :: String -> NontermIdent -> ConstructorIdent -> Int -> String +seqSemname pre nt con 0 = semname pre nt con +seqSemname pre nt con nr = semname pre nt con ++ "_" ++ show nr + +-- Gives the name of a type +typeName :: NontermIdent -> Int -> String +typeName nt 0 = "T_" ++ show nt +typeName nt n = "T_" ++ show nt ++ "_" ++ show n + +ntOfVisit :: NontermIdent -> Int -> NontermIdent +ntOfVisit nt 0 = nt +ntOfVisit nt n = Ident (show nt ++ "_" ++ show n) (getPos nt) + +-- Gives the name of a visit function +visitname :: String -> NontermIdent -> Int -> String +visitname pre nt n = pre ++ getName nt ++ "_" ++ show n {-# LINE 258 "src-generated/GenerateCode.hs" #-} {-# LINE 1042 "src-ag/GenerateCode.ag" #-} - -toNamedType :: Bool -> NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> Code.NamedType -toNamedType genStrict nt con nm tp - = Code.Named genStrict strNm tp - where strNm = recordFieldname nt con nm + +toNamedType :: Bool -> NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> Code.NamedType +toNamedType genStrict nt con nm tp + = Code.Named genStrict strNm tp + where strNm = recordFieldname nt con nm {-# LINE 266 "src-generated/GenerateCode.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper diff --git a/src-generated/HsToken.hs b/src-generated/HsToken.hs --- a/src-generated/HsToken.hs +++ b/src-generated/HsToken.hs @@ -3,9 +3,9 @@ -- UUAGC 0.9.53 (src-ag/HsToken.ag) module HsToken where {-# LINE 2 "src-ag/HsToken.ag" #-} - -import CommonTypes -import UU.Scanner.Position(Pos) + +import CommonTypes +import UU.Scanner.Position(Pos) {-# LINE 10 "src-generated/HsToken.hs" #-} -- HsToken ----------------------------------------------------- {- diff --git a/src-generated/Interfaces.hs b/src-generated/Interfaces.hs --- a/src-generated/Interfaces.hs +++ b/src-generated/Interfaces.hs @@ -3,9 +3,9 @@ -- UUAGC 0.9.53 (src-ag/Interfaces.ag) module Interfaces where {-# LINE 2 "src-ag/Interfaces.ag" #-} - -import CommonTypes -import SequentialTypes + +import CommonTypes +import SequentialTypes {-# LINE 10 "src-generated/Interfaces.hs" #-} -- IRoot ------------------------------------------------------- {- diff --git a/src-generated/InterfacesRules.hs b/src-generated/InterfacesRules.hs --- a/src-generated/InterfacesRules.hs +++ b/src-generated/InterfacesRules.hs @@ -4,9 +4,9 @@ module InterfacesRules where {-# LINE 2 "src-ag/Interfaces.ag" #-} - -import CommonTypes -import SequentialTypes + +import CommonTypes +import SequentialTypes {-# LINE 11 "src-generated/InterfacesRules.hs" #-} {-# LINE 10 "src-ag/InterfacesRules.lag" #-} diff --git a/src-generated/KWOrder.hs b/src-generated/KWOrder.hs --- a/src-generated/KWOrder.hs +++ b/src-generated/KWOrder.hs @@ -3,77 +3,77 @@ module KWOrder where {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 11 "src-generated/KWOrder.hs" #-} {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 17 "src-generated/KWOrder.hs" #-} {-# LINE 2 "src-ag/HsToken.ag" #-} - -import CommonTypes -import UU.Scanner.Position(Pos) + +import CommonTypes +import UU.Scanner.Position(Pos) {-# LINE 23 "src-generated/KWOrder.hs" #-} {-# LINE 2 "src-ag/AbstractSyntax.ag" #-} - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import Macro --marcos -import CommonTypes -import ErrorMessages + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import Macro --marcos +import CommonTypes +import ErrorMessages {-# LINE 35 "src-generated/KWOrder.hs" #-} {-# LINE 10 "src-ag/KWOrder.ag" #-} - -import AbstractSyntax -import HsToken -import Expression -import Patterns -import Options -import PPUtil -import Pretty -import Knuth1 -import KennedyWarren -import ExecutionPlan -import Data.Maybe -import Debug.Trace -import Data.Set(Set) -import Data.Map(Map) -import Data.Sequence(Seq) -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import Data.Monoid(mappend,mempty) + +import AbstractSyntax +import HsToken +import Expression +import Patterns +import Options +import PPUtil +import Pretty +import Knuth1 +import KennedyWarren +import ExecutionPlan +import Data.Maybe +import Debug.Trace +import Data.Set(Set) +import Data.Map(Map) +import Data.Sequence(Seq) +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import Data.Monoid(mappend,mempty) {-# LINE 58 "src-generated/KWOrder.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 125 "src-ag/KWOrder.ag" #-} - --- a depends on b, thus a is a successor of b -depToEdge :: Dependency -> Edge -depToEdge (Dependency a b) = (occToVertex False b, occToVertex True a) - -occToVertex :: Bool -> Occurrence -> Vertex -occToVertex _ (OccRule nm) = VRule nm -occToVertex isDependency (OccAttr c a) - | c == _LOC = VAttr Syn c a -- local attributes are treated as synthesized attrs of 'loc' - | c == _INST = VChild a -- higher-order attributes are treated as children - | otherwise = VAttr kind c a where - kind | isDependency && c == _LHS = Inh -- these dependencies have the property that - | isDependency && c /= _LHS = Syn -- they can all be faked by writing a 'const' rule - | not isDependency && c == _LHS = Syn -- Perhaps we should also allow other forms of dependencies - | not isDependency && c /= _LHS = Inh -- as well, such as two inherited attributes, which would - -- force them in different visits + +-- a depends on b, thus a is a successor of b +depToEdge :: Dependency -> Edge +depToEdge (Dependency a b) = (occToVertex False b, occToVertex True a) + +occToVertex :: Bool -> Occurrence -> Vertex +occToVertex _ (OccRule nm) = VRule nm +occToVertex isDependency (OccAttr c a) + | c == _LOC = VAttr Syn c a -- local attributes are treated as synthesized attrs of 'loc' + | c == _INST = VChild a -- higher-order attributes are treated as children + | otherwise = VAttr kind c a where + kind | isDependency && c == _LHS = Inh -- these dependencies have the property that + | isDependency && c /= _LHS = Syn -- they can all be faked by writing a 'const' rule + | not isDependency && c == _LHS = Syn -- Perhaps we should also allow other forms of dependencies + | not isDependency && c /= _LHS = Inh -- as well, such as two inherited attributes, which would + -- force them in different visits {-# LINE 78 "src-generated/KWOrder.hs" #-} -- Child ------------------------------------------------------- -- wrapper diff --git a/src-generated/LOAG/Order.hs b/src-generated/LOAG/Order.hs --- a/src-generated/LOAG/Order.hs +++ b/src-generated/LOAG/Order.hs @@ -4,328 +4,328 @@ module LOAG.Order where {-# LINE 10 "src-ag/LOAG/Rep.ag" #-} - -import Data.List (intercalate, foldl', nub) -import Data.Tuple (swap) -import Control.Arrow + +import Data.List (intercalate, foldl', nub) +import Data.Tuple (swap) +import Control.Arrow {-# LINE 12 "src-generated/LOAG/Order.hs" #-} {-# LINE 2 "src-ag/HsToken.ag" #-} - -import CommonTypes -import UU.Scanner.Position(Pos) + +import CommonTypes +import UU.Scanner.Position(Pos) {-# LINE 18 "src-generated/LOAG/Order.hs" #-} {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 24 "src-generated/LOAG/Order.hs" #-} {-# LINE 2 "src-ag/CodeSyntax.ag" #-} - -import Patterns -import CommonTypes -import Data.Map(Map) -import Data.Set(Set) + +import Patterns +import CommonTypes +import Data.Map(Map) +import Data.Set(Set) {-# LINE 32 "src-generated/LOAG/Order.hs" #-} {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 39 "src-generated/LOAG/Order.hs" #-} {-# LINE 2 "src-ag/AbstractSyntax.ag" #-} - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import Macro --marcos -import CommonTypes -import ErrorMessages + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import Macro --marcos +import CommonTypes +import ErrorMessages {-# LINE 51 "src-generated/LOAG/Order.hs" #-} {-# LINE 13 "src-ag/LOAG/Order.ag" #-} - -import qualified Data.Array as A -import qualified Data.Map as Map -import qualified Data.IntMap as IMap -import qualified Data.Set as Set -import qualified Data.IntSet as IS -import qualified Data.Sequence as Seq -import qualified CommonTypes as CT -import Control.Monad (forM,when) -import Control.Monad.ST -import Data.Maybe(catMaybes) -import Data.Monoid(mappend,mempty) -import Data.STRef -import AbstractSyntax -import qualified LOAG.AOAG as AOAG -import LOAG.Common -import LOAG.Chordal -import LOAG.Rep -import LOAG.Graphs -import CodeSyntax -import Data.Maybe (isJust, fromJust) -import ExecutionPlan -import GrammarInfo -import HsToken (HsToken(..)) -import Pretty -import qualified System.IO as IO -import System.IO.Unsafe + +import qualified Data.Array as A +import qualified Data.Map as Map +import qualified Data.IntMap as IMap +import qualified Data.Set as Set +import qualified Data.IntSet as IS +import qualified Data.Sequence as Seq +import qualified CommonTypes as CT +import Control.Monad (forM,when) +import Control.Monad.ST +import Data.Maybe(catMaybes) +import Data.Monoid(mappend,mempty) +import Data.STRef +import AbstractSyntax +import qualified LOAG.AOAG as AOAG +import LOAG.Common +import LOAG.Chordal +import LOAG.Rep +import LOAG.Graphs +import CodeSyntax +import Data.Maybe (isJust, fromJust) +import ExecutionPlan +import GrammarInfo +import HsToken (HsToken(..)) +import Pretty +import qualified System.IO as IO +import System.IO.Unsafe {-# LINE 81 "src-generated/LOAG/Order.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 13 "src-ag/LOAG/Prepare.ag" #-} - --- | Translating UUAGC types to MyTypes -drhs f | f == _LHS = Inh - | f == _LOC = AnyDir - | f == _INST = AnyDir - | otherwise = Syn -dlhs f | f == _LHS = Syn - | f == _LOC = AnyDir - | f == _INST = AnyDir - | otherwise = Inh - -depToEdge :: PMP_R -> PLabel -> Dependency -> Edge -depToEdge pmpr p e = - (findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f1) (getName i1, drhs f1), - findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f2) (getName i2, dlhs f2)) - where Dependency (OccAttr f1 i1) (OccAttr f2 i2) = e - -vertexToAttr :: NMP -> Vertex -> Attributes -vertexToAttr nmp v = Map.singleton (identifier a) (fromMyTy ty) - where (MyAttribute ty (a,_)) = findWithErr nmp "vertexToAttr" v - + +-- | Translating UUAGC types to MyTypes +drhs f | f == _LHS = Inh + | f == _LOC = AnyDir + | f == _INST = AnyDir + | otherwise = Syn +dlhs f | f == _LHS = Syn + | f == _LOC = AnyDir + | f == _INST = AnyDir + | otherwise = Inh + +depToEdge :: PMP_R -> PLabel -> Dependency -> Edge +depToEdge pmpr p e = + (findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f1) (getName i1, drhs f1), + findWithErr pmpr "depToEdge" $ MyOccurrence (p,getName f2) (getName i2, dlhs f2)) + where Dependency (OccAttr f1 i1) (OccAttr f2 i2) = e + +vertexToAttr :: NMP -> Vertex -> Attributes +vertexToAttr nmp v = Map.singleton (identifier a) (fromMyTy ty) + where (MyAttribute ty (a,_)) = findWithErr nmp "vertexToAttr" v + {-# LINE 106 "src-generated/LOAG/Order.hs" #-} {-# LINE 292 "src-ag/LOAG/Prepare.ag" #-} - --- | Replace the references to local attributes, by his attrs dependencies, --- | rendering the local attributes 'transparent'. -repLocRefs :: SF_P -> SF_P -> SF_P -repLocRefs lfp sfp = - Map.map (setConcatMap $ rep Set.empty) sfp - where rep :: Set.Set MyOccurrence -> MyOccurrence -> Set.Set MyOccurrence - rep done occ | occ `Set.member` done = Set.empty - | isLoc occ = setConcatMap (rep $ Set.insert occ done) $ - findWithErr lfp "repping locals" occ - | otherwise = Set.singleton occ - --- | Add dependencies from a higher order child to all its attributes -addHigherOrders :: SF_P -> SF_P -> SF_P -addHigherOrders lfp sfp = - Map.mapWithKey f $ Map.map (setConcatMap (\mo -> f mo (Set.singleton mo))) sfp - where f :: MyOccurrence -> Set.Set MyOccurrence -> Set.Set MyOccurrence - f mo@(MyOccurrence (p,f) _) deps = - let ho = ((p,"inst") >.< (f,AnyDir)) - in if ho `Map.member` lfp - then ho `Set.insert` deps - else deps + +-- | Replace the references to local attributes, by his attrs dependencies, +-- | rendering the local attributes 'transparent'. +repLocRefs :: SF_P -> SF_P -> SF_P +repLocRefs lfp sfp = + Map.map (setConcatMap $ rep Set.empty) sfp + where rep :: Set.Set MyOccurrence -> MyOccurrence -> Set.Set MyOccurrence + rep done occ | occ `Set.member` done = Set.empty + | isLoc occ = setConcatMap (rep $ Set.insert occ done) $ + findWithErr lfp "repping locals" occ + | otherwise = Set.singleton occ + +-- | Add dependencies from a higher order child to all its attributes +addHigherOrders :: SF_P -> SF_P -> SF_P +addHigherOrders lfp sfp = + Map.mapWithKey f $ Map.map (setConcatMap (\mo -> f mo (Set.singleton mo))) sfp + where f :: MyOccurrence -> Set.Set MyOccurrence -> Set.Set MyOccurrence + f mo@(MyOccurrence (p,f) _) deps = + let ho = ((p,"inst") >.< (f,AnyDir)) + in if ho `Map.member` lfp + then ho `Set.insert` deps + else deps {-# LINE 131 "src-generated/LOAG/Order.hs" #-} {-# LINE 42 "src-ag/LOAG/Order.ag" #-} - -fst' (a,_,_) = a -snd' (_,b,_) = b -trd' (_,_,c) = c + +fst' (a,_,_) = a +snd' (_,b,_) = b +trd' (_,_,c) = c {-# LINE 138 "src-generated/LOAG/Order.hs" #-} {-# LINE 95 "src-ag/LOAG/Order.ag" #-} - -data AltAttr = AltAttr Identifier Identifier Bool - deriving (Eq, Ord, Show) - -edgeToDep :: PMP -> Edge -> Dependency -edgeToDep pmp (f,t) = - Dependency (OccAttr (identifier f1) (identifier i1)) - (OccAttr (identifier f2) (identifier i2)) - where (MyOccurrence (_,f1) (i1,_),MyOccurrence (_,f2) (i2,_)) - = (findWithErr pmp "edgeToDep" f, - findWithErr pmp "edgeToDep" t) - -ppAds :: Options -> PMP -> [Edge] -> PP_Doc -ppAds opts pmp = foldr ((>-<) . ppEdge opts pmp) empty - -ppEdge :: Options -> PMP -> Edge -> PP_Doc -ppEdge opts pmp (f,t) = - text sem >#< text (show ty) >|< " | " >|< text p >|< " " - >|< ppOcc pmp f >|< text " < " >|< ppOcc pmp t - where (MyOccurrence ((ty,p),_) _) = pmp Map.! f - sem | lcKeywords opts = "sem" - | otherwise = "SEM" - -ppOcc :: PMP -> Vertex -> PP_Doc -ppOcc pmp v = text f >|< text "." >|< fst a - where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v - + +data AltAttr = AltAttr Identifier Identifier Bool + deriving (Eq, Ord, Show) + +edgeToDep :: PMP -> Edge -> Dependency +edgeToDep pmp (f,t) = + Dependency (OccAttr (identifier f1) (identifier i1)) + (OccAttr (identifier f2) (identifier i2)) + where (MyOccurrence (_,f1) (i1,_),MyOccurrence (_,f2) (i2,_)) + = (findWithErr pmp "edgeToDep" f, + findWithErr pmp "edgeToDep" t) + +ppAds :: Options -> PMP -> [Edge] -> PP_Doc +ppAds opts pmp = foldr ((>-<) . ppEdge opts pmp) empty + +ppEdge :: Options -> PMP -> Edge -> PP_Doc +ppEdge opts pmp (f,t) = + text sem >#< text (show ty) >|< " | " >|< text p >|< " " + >|< ppOcc pmp f >|< text " < " >|< ppOcc pmp t + where (MyOccurrence ((ty,p),_) _) = pmp Map.! f + sem | lcKeywords opts = "sem" + | otherwise = "SEM" + +ppOcc :: PMP -> Vertex -> PP_Doc +ppOcc pmp v = text f >|< text "." >|< fst a + where (MyOccurrence ((t,p),f) a) = findWithErr pmp "ppOcc" v + {-# LINE 168 "src-generated/LOAG/Order.hs" #-} {-# LINE 239 "src-ag/LOAG/Order.ag" #-} - -getVss (done,intros,rules,vnrs) ps tdp synsO lfp nmpr pmp pmpr fty visMap ruleMap hoMap = do - ref <- newSTRef done - introed <- newSTRef intros - ruleref <- newSTRef rules - vnrsref <- newSTRef vnrs - lists <- forM synsO (visit ref introed ruleref vnrsref . (pmp Map.!)) - done <- readSTRef ref - intros <- readSTRef introed - rules <- readSTRef ruleref - vnrs <- readSTRef vnrsref - return (concat lists, (done, intros, rules, vnrs)) - where - hochildren = maybe Set.empty id $ Map.lookup ps hoMap - visit ref introed ruleref vnrsref o@(MyOccurrence (_,f) (_,d)) = do - visited <- readSTRef ref - if (o `Set.member` visited) - then return [] -- already visited - else do -- prevent doubles - modifySTRef ref (Set.insert o) - if inOutput - then do -- has to be calculated in this sequence - rest' <- rest - locs' <- locs - sem' <- sem o - return $ (rest' ++ locs' ++ sem') - else if "lhs" == (snd $ argsOf o) - then return [] -- inherited of parent, nothing todo - else do -- other input occurrence, perform visit - locs' <- locs - rest' <- rest - visit'<- toVisit o - return (rest' ++ locs' ++ visit') - where preds = maybe [] (IS.toList . (tdp A.!)) $ Map.lookup o pmpr - rest = forM preds (visit ref introed ruleref vnrsref. (pmp Map.!)) - >>= (return . concat) - free = maybe [] (Set.toList) $ Map.lookup o lfp - locs = forM free (visit ref introed ruleref vnrsref) - >>= (return . concat) - sem o = do rules <- readSTRef ruleref - if r `Set.member` rules - then return [] - else do writeSTRef ruleref (r `Set.insert` rules) - return [Sem r] - where r = maybe (error "ruleMap") id $ Map.lookup o ruleMap - inOutput = f == "lhs" && d == Syn || f /= "lhs" && d == Inh - toVisit o = do - vnrs <- readSTRef vnrsref - if (child,visnr) `Set.member` vnrs - then return [] - else writeSTRef vnrsref ((child,visnr) `Set.insert` vnrs) >> - if child `Set.member` hochildren - then do intros <- readSTRef introed - case child `Set.member` intros of - True -> return [cvisit] - False -> do - writeSTRef introed (Set.insert child intros) - let occ = (ps,"inst") >.< (child, AnyDir) - preds = Set.toList $ setConcatMap rep $ - lfp Map.! occ - rep :: MyOccurrence -> Set.Set MyOccurrence - rep occ | isLoc occ = Set.insert occ $ - setConcatMap rep $ lfp Map.! occ - | otherwise = Set.singleton occ - rest <- forM preds - (visit ref introed ruleref vnrsref) - sem' <- sem occ - return $ (concat rest) ++ - sem' ++ - [ChildIntro (identifier child)] ++ - [cvisit] - else return [cvisit] - where cvisit= ChildVisit (identifier child) ntid visnr - child = snd $ argsOf o - ntid = ((\(NT name _ _ )-> name) . fromMyTy) nt - visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o)) - nt = fty Map.! (ps,child) + +getVss (done,intros,rules,vnrs) ps tdp synsO lfp nmpr pmp pmpr fty visMap ruleMap hoMap = do + ref <- newSTRef done + introed <- newSTRef intros + ruleref <- newSTRef rules + vnrsref <- newSTRef vnrs + lists <- forM synsO (visit ref introed ruleref vnrsref . (pmp Map.!)) + done <- readSTRef ref + intros <- readSTRef introed + rules <- readSTRef ruleref + vnrs <- readSTRef vnrsref + return (concat lists, (done, intros, rules, vnrs)) + where + hochildren = maybe Set.empty id $ Map.lookup ps hoMap + visit ref introed ruleref vnrsref o@(MyOccurrence (_,f) (_,d)) = do + visited <- readSTRef ref + if (o `Set.member` visited) + then return [] -- already visited + else do -- prevent doubles + modifySTRef ref (Set.insert o) + if inOutput + then do -- has to be calculated in this sequence + rest' <- rest + locs' <- locs + sem' <- sem o + return $ (rest' ++ locs' ++ sem') + else if "lhs" == (snd $ argsOf o) + then return [] -- inherited of parent, nothing todo + else do -- other input occurrence, perform visit + locs' <- locs + rest' <- rest + visit'<- toVisit o + return (rest' ++ locs' ++ visit') + where preds = maybe [] (IS.toList . (tdp A.!)) $ Map.lookup o pmpr + rest = forM preds (visit ref introed ruleref vnrsref. (pmp Map.!)) + >>= (return . concat) + free = maybe [] (Set.toList) $ Map.lookup o lfp + locs = forM free (visit ref introed ruleref vnrsref) + >>= (return . concat) + sem o = do rules <- readSTRef ruleref + if r `Set.member` rules + then return [] + else do writeSTRef ruleref (r `Set.insert` rules) + return [Sem r] + where r = maybe (error "ruleMap") id $ Map.lookup o ruleMap + inOutput = f == "lhs" && d == Syn || f /= "lhs" && d == Inh + toVisit o = do + vnrs <- readSTRef vnrsref + if (child,visnr) `Set.member` vnrs + then return [] + else writeSTRef vnrsref ((child,visnr) `Set.insert` vnrs) >> + if child `Set.member` hochildren + then do intros <- readSTRef introed + case child `Set.member` intros of + True -> return [cvisit] + False -> do + writeSTRef introed (Set.insert child intros) + let occ = (ps,"inst") >.< (child, AnyDir) + preds = Set.toList $ setConcatMap rep $ + lfp Map.! occ + rep :: MyOccurrence -> Set.Set MyOccurrence + rep occ | isLoc occ = Set.insert occ $ + setConcatMap rep $ lfp Map.! occ + | otherwise = Set.singleton occ + rest <- forM preds + (visit ref introed ruleref vnrsref) + sem' <- sem occ + return $ (concat rest) ++ + sem' ++ + [ChildIntro (identifier child)] ++ + [cvisit] + else return [cvisit] + where cvisit= ChildVisit (identifier child) ntid visnr + child = snd $ argsOf o + ntid = ((\(NT name _ _ )-> name) . fromMyTy) nt + visnr = (\x-> visMap IMap.! x) (nmpr Map.! (nt <.> attr o)) + nt = fty Map.! (ps,child) {-# LINE 248 "src-generated/LOAG/Order.hs" #-} {-# LINE 356 "src-ag/LOAG/Order.ag" #-} - -repToAg :: LOAGRep -> Grammar -> Ag -repToAg sem (Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) = - Ag bounds_s bounds_p de (map toNt dats) - where - pmp = (pmp_LOAGRep_LOAGRep sem) - pmpr = (pmpr_LOAGRep_LOAGRep sem) - nmp = (nmp_LOAGRep_LOAGRep sem) - nmpr = (nmpr_LOAGRep_LOAGRep sem) - genA = gen_LOAGRep_LOAGRep sem - fieldM = fieldMap_LOAGRep_LOAGRep sem - genEdge (f,t) = (gen f, gen t) - fsInP = map2F (fsInP_LOAGRep_LOAGRep sem) - siblings (f, t) = ofld A.! f == ofld A.! t - ofld = (ofld_LOAGRep_LOAGRep sem) - sfp = map2F' (sfp_LOAGRep_LOAGRep sem) - afp = filter inOutput . ap - ap = map (findWithErr pmpr "building ap") . map2F (ap_LOAGRep_LOAGRep sem) - inss = inss_LOAGRep_LOAGRep sem - gen v = genA A.! v - ain = map (findWithErr nmpr "building an") . map2F (ain_LOAGRep_LOAGRep sem) - asn = map (findWithErr nmpr "building an") . map2F (asn_LOAGRep_LOAGRep sem) - inOutput = not . inContext - inContext f = (f1 == "lhs" && d1 == Inh || f1 /= "lhs" && d1 == Syn) - where (MyOccurrence (_,f1) (_,d1)) = pmp Map.! f - de = [ e | p <- ps, e <- dpe p ] - dpe p = [ (findWithErr pmpr "building dpe" a, b) - | b <- ap p, a <- Set.toList $ sfp (findWithErr pmp "fetching sfp" b) ] - ps = ps_LOAGRep_LOAGRep sem - bounds_p = if Map.null pmp then (0,-1) - else (fst $ Map.findMin pmp, fst $ Map.findMax pmp) - bounds_s = if Map.null nmp then (0,-1) - else (fst $ Map.findMin nmp, fst $ Map.findMax nmp) - - - - toNt :: Nonterminal -> Nt - toNt (Nonterminal ntid _ _ _ prods) = Nt nt dpf dpt - (addD Inh $ ain ty) (addD Syn $ asn ty) (map (toPr ty) prods) - where nt = getName ntid - ty = TyData nt - dpt = [ (as, ai) | ai <- ain ty - , as <- nub$ [ gen s | - i <- inss A.! ai - , s <- map (pmpr Map.!) $ - Set.toList (sfp $ pmp Map.! i) - , siblings (s,i)]] - dpf = [ (ai, as) | as <- asn ty - , ai <- nub$ [ gen i | - s <- inss A.! as - , i <- map (pmpr Map.!) $ - Set.toList (sfp $ pmp Map.! s) - , siblings (i,s)]] - addD d = map (\i -> (i,inss A.! i,d)) - toPr :: MyType -> Production -> Pr - toPr ty (Production con _ _ _ _ _ _) = - Pr p dpp fc_occs (map toFd $ fsInP p) - where p = (ty, getName con) - dpp = [ (f',t) - | t <- afp p, f <- (Set.toList $ sfp (pmp Map.! t)) - , let f' = pmpr Map.! f - , not (siblings (f',t))] - fc_occs = foldl' match [] fss - where fss = fsInP p - match s fs = [ ready (inp, out) lhs | inp <- Set.toList inhs - , out <- Set.toList syns] ++ s - where ((inhs, syns), lhs) - | (snd fs) /= "lhs" = - (swap (fieldM Map.! fs),False) - | otherwise = (fieldM Map.! fs, True) - ready e@(f,t) b = (e', genEdge e', b) - where e' = (pmpr Map.! f, pmpr Map.! t) - toFd :: (PLabel, FLabel) -> Fd - toFd fs@((TyData ty, pr), fd) = Fd fd ty inhs syns - where (is,ss) = fieldM Map.! fs - inhs = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList is - syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss - - + +repToAg :: LOAGRep -> Grammar -> Ag +repToAg sem (Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) = + Ag bounds_s bounds_p de (map toNt dats) + where + pmp = (pmp_LOAGRep_LOAGRep sem) + pmpr = (pmpr_LOAGRep_LOAGRep sem) + nmp = (nmp_LOAGRep_LOAGRep sem) + nmpr = (nmpr_LOAGRep_LOAGRep sem) + genA = gen_LOAGRep_LOAGRep sem + fieldM = fieldMap_LOAGRep_LOAGRep sem + genEdge (f,t) = (gen f, gen t) + fsInP = map2F (fsInP_LOAGRep_LOAGRep sem) + siblings (f, t) = ofld A.! f == ofld A.! t + ofld = (ofld_LOAGRep_LOAGRep sem) + sfp = map2F' (sfp_LOAGRep_LOAGRep sem) + afp = filter inOutput . ap + ap = map (findWithErr pmpr "building ap") . map2F (ap_LOAGRep_LOAGRep sem) + inss = inss_LOAGRep_LOAGRep sem + gen v = genA A.! v + ain = map (findWithErr nmpr "building an") . map2F (ain_LOAGRep_LOAGRep sem) + asn = map (findWithErr nmpr "building an") . map2F (asn_LOAGRep_LOAGRep sem) + inOutput = not . inContext + inContext f = (f1 == "lhs" && d1 == Inh || f1 /= "lhs" && d1 == Syn) + where (MyOccurrence (_,f1) (_,d1)) = pmp Map.! f + de = [ e | p <- ps, e <- dpe p ] + dpe p = [ (findWithErr pmpr "building dpe" a, b) + | b <- ap p, a <- Set.toList $ sfp (findWithErr pmp "fetching sfp" b) ] + ps = ps_LOAGRep_LOAGRep sem + bounds_p = if Map.null pmp then (0,-1) + else (fst $ Map.findMin pmp, fst $ Map.findMax pmp) + bounds_s = if Map.null nmp then (0,-1) + else (fst $ Map.findMin nmp, fst $ Map.findMax nmp) + + + + toNt :: Nonterminal -> Nt + toNt (Nonterminal ntid _ _ _ prods) = Nt nt dpf dpt + (addD Inh $ ain ty) (addD Syn $ asn ty) (map (toPr ty) prods) + where nt = getName ntid + ty = TyData nt + dpt = [ (as, ai) | ai <- ain ty + , as <- nub$ [ gen s | + i <- inss A.! ai + , s <- map (pmpr Map.!) $ + Set.toList (sfp $ pmp Map.! i) + , siblings (s,i)]] + dpf = [ (ai, as) | as <- asn ty + , ai <- nub$ [ gen i | + s <- inss A.! as + , i <- map (pmpr Map.!) $ + Set.toList (sfp $ pmp Map.! s) + , siblings (i,s)]] + addD d = map (\i -> (i,inss A.! i,d)) + toPr :: MyType -> Production -> Pr + toPr ty (Production con _ _ _ _ _ _) = + Pr p dpp fc_occs (map toFd $ fsInP p) + where p = (ty, getName con) + dpp = [ (f',t) + | t <- afp p, f <- (Set.toList $ sfp (pmp Map.! t)) + , let f' = pmpr Map.! f + , not (siblings (f',t))] + fc_occs = foldl' match [] fss + where fss = fsInP p + match s fs = [ ready (inp, out) lhs | inp <- Set.toList inhs + , out <- Set.toList syns] ++ s + where ((inhs, syns), lhs) + | (snd fs) /= "lhs" = + (swap (fieldM Map.! fs),False) + | otherwise = (fieldM Map.! fs, True) + ready e@(f,t) b = (e', genEdge e', b) + where e' = (pmpr Map.! f, pmpr Map.! t) + toFd :: (PLabel, FLabel) -> Fd + toFd fs@((TyData ty, pr), fd) = Fd fd ty inhs syns + where (is,ss) = fieldM Map.! fs + inhs = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList is + syns = map (((genA A.!) &&& id).(pmpr Map.!))$ Set.toList ss + + {-# LINE 330 "src-generated/LOAG/Order.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper @@ -2964,9 +2964,9 @@ -- MySegment --------------------------------------------------- -- wrapper -data Inh_MySegment = Inh_MySegment { ain_Inh_MySegment :: (MyType -> MyAttributes), asn_Inh_MySegment :: (MyType -> MyAttributes), done_Inh_MySegment :: ( (Set.Set MyOccurrence, Set.Set FLabel +data Inh_MySegment = Inh_MySegment { ain_Inh_MySegment :: (MyType -> MyAttributes), asn_Inh_MySegment :: (MyType -> MyAttributes), done_Inh_MySegment :: ( (Set.Set MyOccurrence, Set.Set FLabel , Set.Set Identifier, Set.Set (FLabel,Int))), fty_Inh_MySegment :: (FTY), hoMapf_Inh_MySegment :: (HOMap), lfpf_Inh_MySegment :: (SF_P), nmp_Inh_MySegment :: (NMP), nmprf_Inh_MySegment :: (NMP_R), options_Inh_MySegment :: (Options), pmpf_Inh_MySegment :: (PMP), pmprf_Inh_MySegment :: (PMP_R), ps_Inh_MySegment :: (PLabel), ruleMap_Inh_MySegment :: (Map.Map MyOccurrence Identifier), tdp_Inh_MySegment :: (TDPRes), visMapf_Inh_MySegment :: (IMap.IntMap Int), visitnum_Inh_MySegment :: (Int) } -data Syn_MySegment = Syn_MySegment { done_Syn_MySegment :: ( (Set.Set MyOccurrence, Set.Set FLabel +data Syn_MySegment = Syn_MySegment { done_Syn_MySegment :: ( (Set.Set MyOccurrence, Set.Set FLabel ,Set.Set Identifier, Set.Set (FLabel,Int))), evisits_Syn_MySegment :: (Visit), self_Syn_MySegment :: (MySegment), synsO_Syn_MySegment :: ([Int]), visitnum_Syn_MySegment :: (Int), visnr_Syn_MySegment :: (Int) } {-# INLINABLE wrap_MySegment #-} wrap_MySegment :: T_MySegment -> Inh_MySegment -> (Syn_MySegment ) @@ -2992,9 +2992,9 @@ } data T_MySegment_s66 = C_MySegment_s66 type T_MySegment_v64 = (T_MySegment_vIn64 ) -> (T_MySegment_vOut64 ) -data T_MySegment_vIn64 = T_MySegment_vIn64 (MyType -> MyAttributes) (MyType -> MyAttributes) ( (Set.Set MyOccurrence, Set.Set FLabel +data T_MySegment_vIn64 = T_MySegment_vIn64 (MyType -> MyAttributes) (MyType -> MyAttributes) ( (Set.Set MyOccurrence, Set.Set FLabel , Set.Set Identifier, Set.Set (FLabel,Int))) (FTY) (HOMap) (SF_P) (NMP) (NMP_R) (Options) (PMP) (PMP_R) (PLabel) (Map.Map MyOccurrence Identifier) (TDPRes) (IMap.IntMap Int) (Int) -data T_MySegment_vOut64 = T_MySegment_vOut64 ( (Set.Set MyOccurrence, Set.Set FLabel +data T_MySegment_vOut64 = T_MySegment_vOut64 ( (Set.Set MyOccurrence, Set.Set FLabel ,Set.Set Identifier, Set.Set (FLabel,Int))) (Visit) (MySegment) ([Int]) (Int) (Int) {-# NOINLINE sem_MySegment_MySegment #-} sem_MySegment_MySegment :: (Int) -> ([Int]) -> ([Int]) -> (Maybe [Int]) -> (Maybe [Int]) -> T_MySegment @@ -3016,7 +3016,7 @@ _lhsOevisits :: Visit _lhsOevisits = rule300 _inhs _kind _lhsIvisitnum _steps _syns _steps = rule301 _lhsIoptions _vss - _lhsOdone :: (Set.Set MyOccurrence, Set.Set FLabel + _lhsOdone :: (Set.Set MyOccurrence, Set.Set FLabel ,Set.Set Identifier, Set.Set (FLabel,Int)) (_vss,_lhsOdone) = rule302 _lhsIdone _lhsIfty _lhsIhoMapf _lhsIlfpf _lhsInmprf _lhsIpmpf _lhsIpmprf _lhsIps _lhsIruleMap _lhsItdp _lhsIvisMapf _synsO _self = rule303 arg_inhAttr_ arg_inhOccs_ arg_synAttr_ arg_synOccs_ arg_visnr_ @@ -3086,7 +3086,7 @@ {-# LINE 3087 "src-generated/LOAG/Order.hs" #-} {-# INLINE rule302 #-} {-# LINE 235 "src-ag/LOAG/Order.ag" #-} - rule302 = \ ((_lhsIdone) :: (Set.Set MyOccurrence, Set.Set FLabel + rule302 = \ ((_lhsIdone) :: (Set.Set MyOccurrence, Set.Set FLabel , Set.Set Identifier, Set.Set (FLabel,Int))) ((_lhsIfty) :: FTY) ((_lhsIhoMapf) :: HOMap) ((_lhsIlfpf) :: SF_P) ((_lhsInmprf) :: NMP_R) ((_lhsIpmpf) :: PMP) ((_lhsIpmprf) :: PMP_R) ((_lhsIps) :: PLabel) ((_lhsIruleMap) :: Map.Map MyOccurrence Identifier) ((_lhsItdp) :: TDPRes) ((_lhsIvisMapf) :: IMap.IntMap Int) _synsO -> {-# LINE 235 "src-ag/LOAG/Order.ag" #-} (runST $ getVss _lhsIdone _lhsIps _lhsItdp _synsO @@ -3108,7 +3108,7 @@ -- MySegments -------------------------------------------------- -- wrapper -data Inh_MySegments = Inh_MySegments { ain_Inh_MySegments :: (MyType -> MyAttributes), asn_Inh_MySegments :: (MyType -> MyAttributes), done_Inh_MySegments :: ( (Set.Set MyOccurrence, Set.Set FLabel +data Inh_MySegments = Inh_MySegments { ain_Inh_MySegments :: (MyType -> MyAttributes), asn_Inh_MySegments :: (MyType -> MyAttributes), done_Inh_MySegments :: ( (Set.Set MyOccurrence, Set.Set FLabel , Set.Set Identifier, Set.Set (FLabel,Int))), fty_Inh_MySegments :: (FTY), hoMapf_Inh_MySegments :: (HOMap), lfpf_Inh_MySegments :: (SF_P), nmp_Inh_MySegments :: (NMP), nmprf_Inh_MySegments :: (NMP_R), options_Inh_MySegments :: (Options), pmpf_Inh_MySegments :: (PMP), pmprf_Inh_MySegments :: (PMP_R), ps_Inh_MySegments :: (PLabel), ruleMap_Inh_MySegments :: (Map.Map MyOccurrence Identifier), tdp_Inh_MySegments :: (TDPRes), visMapf_Inh_MySegments :: (IMap.IntMap Int), visitnum_Inh_MySegments :: (Int) } data Syn_MySegments = Syn_MySegments { evisits_Syn_MySegments :: (Visits), self_Syn_MySegments :: (MySegments), visitnum_Syn_MySegments :: (Int) } {-# INLINABLE wrap_MySegments #-} @@ -3135,7 +3135,7 @@ } data T_MySegments_s69 = C_MySegments_s69 type T_MySegments_v67 = (T_MySegments_vIn67 ) -> (T_MySegments_vOut67 ) -data T_MySegments_vIn67 = T_MySegments_vIn67 (MyType -> MyAttributes) (MyType -> MyAttributes) ( (Set.Set MyOccurrence, Set.Set FLabel +data T_MySegments_vIn67 = T_MySegments_vIn67 (MyType -> MyAttributes) (MyType -> MyAttributes) ( (Set.Set MyOccurrence, Set.Set FLabel , Set.Set Identifier, Set.Set (FLabel,Int))) (FTY) (HOMap) (SF_P) (NMP) (NMP_R) (Options) (PMP) (PMP_R) (PLabel) (Map.Map MyOccurrence Identifier) (TDPRes) (IMap.IntMap Int) (Int) data T_MySegments_vOut67 = T_MySegments_vOut67 (Visits) (MySegments) (Int) {-# NOINLINE sem_MySegments_Cons #-} @@ -3193,14 +3193,14 @@ in C_MySegments_s68 v67 {-# INLINE rule307 #-} {-# LINE 220 "src-ag/LOAG/Order.ag" #-} - rule307 = \ ((_lhsIdone) :: (Set.Set MyOccurrence, Set.Set FLabel + rule307 = \ ((_lhsIdone) :: (Set.Set MyOccurrence, Set.Set FLabel , Set.Set Identifier, Set.Set (FLabel,Int))) -> {-# LINE 220 "src-ag/LOAG/Order.ag" #-} _lhsIdone {-# LINE 3201 "src-generated/LOAG/Order.hs" #-} {-# INLINE rule308 #-} {-# LINE 221 "src-ag/LOAG/Order.ag" #-} - rule308 = \ ((_hdIdone) :: (Set.Set MyOccurrence, Set.Set FLabel + rule308 = \ ((_hdIdone) :: (Set.Set MyOccurrence, Set.Set FLabel ,Set.Set Identifier, Set.Set (FLabel,Int))) -> {-# LINE 221 "src-ag/LOAG/Order.ag" #-} _hdIdone diff --git a/src-generated/LOAG/Rep.hs b/src-generated/LOAG/Rep.hs --- a/src-generated/LOAG/Rep.hs +++ b/src-generated/LOAG/Rep.hs @@ -2,18 +2,18 @@ -- UUAGC 0.9.53 (src-ag/LOAG/Rep.ag) module LOAG.Rep where - -import CommonTypes -import AbstractSyntax -import LOAG.Common -import qualified Data.Array as A -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Data.List (intercalate, foldl', nub) -import Data.Tuple (swap) -import Control.Arrow +import CommonTypes +import AbstractSyntax +import LOAG.Common +import qualified Data.Array as A +import qualified Data.Map as Map +import qualified Data.Set as Set + + +import Data.List (intercalate, foldl', nub) +import Data.Tuple (swap) +import Control.Arrow -- FieldAtt ---------------------------------------------------- {- visit 0: diff --git a/src-generated/Macro.hs b/src-generated/Macro.hs --- a/src-generated/Macro.hs +++ b/src-generated/Macro.hs @@ -3,8 +3,8 @@ -- UUAGC 0.9.53 (src-ag/Macro.ag) module Macro where {-# LINE 4 "src-ag/Macro.ag" #-} - -import CommonTypes + +import CommonTypes {-# LINE 9 "src-generated/Macro.hs" #-} -- Macro ------------------------------------------------------- {- diff --git a/src-generated/Order.hs b/src-generated/Order.hs --- a/src-generated/Order.hs +++ b/src-generated/Order.hs @@ -3,228 +3,228 @@ module Order where {-# LINE 2 "src-ag/AbstractSyntax.ag" #-} - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import Macro --marcos -import CommonTypes -import ErrorMessages + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import Macro --marcos +import CommonTypes +import ErrorMessages {-# LINE 16 "src-generated/Order.hs" #-} {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 22 "src-generated/Order.hs" #-} {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 29 "src-generated/Order.hs" #-} {-# LINE 10 "src-ag/Order.ag" #-} - --- From uuagc -import CommonTypes -import Patterns -import ErrorMessages -import AbstractSyntax -import Code hiding (Type) -import qualified Code -import Expression -import Options -import SequentialComputation -import SequentialTypes -import CodeSyntax -import GrammarInfo -import HsToken(HsTokensRoot(HsTokensRoot)) -import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) --- From uulib -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Sequence as Seq -import Data.Map(Map) -import Data.Set(Set) -import Data.Sequence(Seq, (><)) -import UU.Util.Utils -import UU.Scanner.Position(Pos(..),initPos) -import Data.Foldable(toList) - --- From haskell libraries -import Control.Monad(liftM) -import qualified Data.Array as Array -import Data.Array((!),bounds,inRange) -import Data.List(elemIndex,partition,sort,mapAccumL,find,nubBy,intersperse,groupBy,transpose) -import qualified Data.Tree as Tree -import Data.Maybe + +-- From uuagc +import CommonTypes +import Patterns +import ErrorMessages +import AbstractSyntax +import Code hiding (Type) +import qualified Code +import Expression +import Options +import SequentialComputation +import SequentialTypes +import CodeSyntax +import GrammarInfo +import HsToken(HsTokensRoot(HsTokensRoot)) +import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) +-- From uulib +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Sequence as Seq +import Data.Map(Map) +import Data.Set(Set) +import Data.Sequence(Seq, (><)) +import UU.Util.Utils +import UU.Scanner.Position(Pos(..),initPos) +import Data.Foldable(toList) + +-- From haskell libraries +import Control.Monad(liftM) +import qualified Data.Array as Array +import Data.Array((!),bounds,inRange) +import Data.List(elemIndex,partition,sort,mapAccumL,find,nubBy,intersperse,groupBy,transpose) +import qualified Data.Tree as Tree +import Data.Maybe {-# LINE 66 "src-generated/Order.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 46 "src-ag/Order.ag" #-} - --- Terminates with an error if the key is not in the map -findWithErr1 :: (Ord k, Show k) => String -> k -> Map k a -> a -findWithErr1 s k - = Map.findWithDefault (error ("findWithErr1 " ++ s ++ ": key " ++ show k ++ " not in map.")) k - -findWithErr2 :: (Ord k, Show k, Show a) => k -> Map k a -> a -findWithErr2 k m - = Map.findWithDefault (error ("findWithErr2: key " ++ show k ++ " not in map: " ++ show m)) k m + +-- Terminates with an error if the key is not in the map +findWithErr1 :: (Ord k, Show k) => String -> k -> Map k a -> a +findWithErr1 s k + = Map.findWithDefault (error ("findWithErr1 " ++ s ++ ": key " ++ show k ++ " not in map.")) k + +findWithErr2 :: (Ord k, Show k, Show a) => k -> Map k a -> a +findWithErr2 k m + = Map.findWithDefault (error ("findWithErr2: key " ++ show k ++ " not in map: " ++ show m)) k m {-# LINE 79 "src-generated/Order.hs" #-} {-# LINE 71 "src-ag/Order.ag" #-} - -startsWith :: String -> String -> Bool -startsWith k h = k == take (length k) h + +startsWith :: String -> String -> Bool +startsWith k h = k == take (length k) h {-# LINE 85 "src-generated/Order.hs" #-} {-# LINE 138 "src-ag/Order.ag" #-} - -getNtName :: Type -> NontermIdent -getNtName (NT nt _ _) = nt -getNtName _ = nullIdent + +getNtName :: Type -> NontermIdent +getNtName (NT nt _ _) = nt +getNtName _ = nullIdent {-# LINE 92 "src-generated/Order.hs" #-} {-# LINE 166 "src-ag/Order.ag" #-} - -data AltAttr = AltAttr Identifier Identifier Bool - deriving (Eq, Ord, Show) + +data AltAttr = AltAttr Identifier Identifier Bool + deriving (Eq, Ord, Show) {-# LINE 98 "src-generated/Order.hs" #-} {-# LINE 239 "src-ag/Order.ag" #-} - -substSelf nt tp - = case tp of - NT n tps defor | n == _SELF -> NT nt tps defor - _ -> tp - -haskellTupel :: [Type] -> Maybe Type -haskellTupel ts = Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" )) + +substSelf nt tp + = case tp of + NT n tps defor | n == _SELF -> NT nt tps defor + _ -> tp + +haskellTupel :: [Type] -> Maybe Type +haskellTupel ts = Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" )) {-# LINE 109 "src-generated/Order.hs" #-} {-# LINE 692 "src-ag/Order.ag" #-} - -swap (a,b) = (b,a) - -showPath :: Table CRule -> [Vertex] -> [String] -showPath ruleTable path - = let look a | inRange (bounds ruleTable) a = [showOrigin (ruleTable ! a)] - | otherwise = ["Vertex " ++ show a] - showOrigin cr | getHasCode cr && getName (getAttr cr) /= "self" = prettyCRule cr ++ " (" ++ show (getPos (getAttr cr)) ++ ")" - | otherwise = prettyCRule cr - in concatMap look path - - -showPathLocal :: Table CRule -> [Vertex] -> [String] -showPathLocal _ [] = [] -showPathLocal ruleTable xs = showP (xs++[-1]) - where showP [] = [] - showP (v1:v2:vs) = let line = step v1 v2 - lines = showP vs - in line:lines - step v1 v2 = " - " ++ a1 - where r1 = ruleTable ! v1 - a1 = show (getAttr r1) - - -limitTo :: Int -> [String] -> [String] -limitTo _ [] = [] -limitTo 0 _ = ["....etcetera, etcetera...."] -limitTo n (x:xs) = x : limitTo (n-1) xs - -showPathNice :: Table CRule -> [Vertex] -> [String] -showPathNice _ [] = [] -showPathNice ruleTable xs = limitTo 100 (showP ((-1):xs++[-1])) - where [maxf, maxa, maxn, maxc] = maxWidths ruleTable (take 100 xs) - showP [] = [] - showP (v1:v2:vs) = let line = step v1 v2 - lines = showP vs - in if null line then lines else line:lines - step v1 v2 | last && first = induced - | last && isSyn r1 = "pass up " ++ alignR maxf "" ++ " " ++ alignL maxa a1 ++ " in " ++ alignR maxn n1 ++ "|" ++ c1 ++ induced - | first&& not(isSyn r2) = "get from above " ++ alignR maxf "" ++ " " ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 - | last = "pass down " ++ alignR maxf f1 ++ "." ++ a1 ++ induced - | isSyn r2 = "get from below " ++ alignR maxf f2 ++ "." ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 - | isLocal r1 = if head a1 == '_' - then "" - else "calculate " ++ alignR maxf "loc" ++ "." ++ a1 - | otherwise = "pass down " ++ alignR maxf f1 ++ "." ++ alignL maxa a1 ++ " to " ++ alignR maxn n2 ++ "|" ++ c2 - where - first = v1<0 - last = v2<0 - r1 = ruleTable ! v1 - r2 = ruleTable ! v2 - a1 = show (getAttr r1) - a2 = show (getAttr r2) - f1 = show (getField r1) - f2 = show (getField r2) - n1 = show (getLhsNt r1) - n2 = show (getLhsNt r2) - c1 = show (getCon r1) - c2 = show (getCon r2) - induced | v2== -2 = " INDUCED dependency to " - | otherwise = "" - - -maxWidths ruleTable vs - = map maximum (transpose (map getWidth vs)) - where getWidth v | v<0 = [0,0,0,0] - | otherwise = map (length . show . ($ (ruleTable!v))) [getField, getAttr, getLhsNt, getCon] - -alignL n xs | k Bool -> Route -> Error -localCycleErr ruleTable o_visit (s:path) - = let cr = ruleTable ! s - attr = getAttr cr - nt = getLhsNt cr - con = getCon cr - in LocalCirc nt con attr o_visit (showPathLocal ruleTable path) - -instCycleErr :: Table CRule -> Bool -> Route -> Error -instCycleErr ruleTable o_visit (s:path) - = let cr = ruleTable ! s - attr = getAttr cr - nt = getLhsNt cr - con = getCon cr - in InstCirc nt con attr o_visit (showPathLocal ruleTable path) - -directCycleErrs :: Table NTAttr -> Table CRule -> Bool -> [EdgeRoutes] -> [Error] -directCycleErrs attrTable ruleTable o_visit xs - = let getNont v = case attrTable ! v of - NTASyn nt _ _ -> nt - NTAInh nt _ _ -> nt - getAttr v = case attrTable ! v of - NTASyn _ a _ -> a - NTAInh _ a _ -> a - sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 - procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) - wrapGroup gr@(((v1,_),_,_):_) = DirectCirc (getNont v1) o_visit (map procCycle gr) - in map wrapGroup (groupBy sameNont xs) - -inducedCycleErrs :: Table NTAttr -> Table CRule -> CInterfaceMap -> [EdgeRoutes] -> [Error] -inducedCycleErrs attrTable ruleTable cim xs - = let getNont v = case attrTable ! v of - NTASyn nt _ _ -> nt - NTAInh nt _ _ -> nt - getAttr v = case attrTable ! v of - NTASyn _ a _ -> a - NTAInh _ a _ -> a - sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 - procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) - wrapGroup gr@(((v1,_),_,_):_) = InducedCirc (getNont v1) (findWithErr1 "inducedCycleErr.cinter" (getNont v1) cim) (map procCycle gr) - in map wrapGroup (groupBy sameNont xs) + +swap (a,b) = (b,a) + +showPath :: Table CRule -> [Vertex] -> [String] +showPath ruleTable path + = let look a | inRange (bounds ruleTable) a = [showOrigin (ruleTable ! a)] + | otherwise = ["Vertex " ++ show a] + showOrigin cr | getHasCode cr && getName (getAttr cr) /= "self" = prettyCRule cr ++ " (" ++ show (getPos (getAttr cr)) ++ ")" + | otherwise = prettyCRule cr + in concatMap look path + + +showPathLocal :: Table CRule -> [Vertex] -> [String] +showPathLocal _ [] = [] +showPathLocal ruleTable xs = showP (xs++[-1]) + where showP [] = [] + showP (v1:v2:vs) = let line = step v1 v2 + lines = showP vs + in line:lines + step v1 v2 = " - " ++ a1 + where r1 = ruleTable ! v1 + a1 = show (getAttr r1) + + +limitTo :: Int -> [String] -> [String] +limitTo _ [] = [] +limitTo 0 _ = ["....etcetera, etcetera...."] +limitTo n (x:xs) = x : limitTo (n-1) xs + +showPathNice :: Table CRule -> [Vertex] -> [String] +showPathNice _ [] = [] +showPathNice ruleTable xs = limitTo 100 (showP ((-1):xs++[-1])) + where [maxf, maxa, maxn, maxc] = maxWidths ruleTable (take 100 xs) + showP [] = [] + showP (v1:v2:vs) = let line = step v1 v2 + lines = showP vs + in if null line then lines else line:lines + step v1 v2 | last && first = induced + | last && isSyn r1 = "pass up " ++ alignR maxf "" ++ " " ++ alignL maxa a1 ++ " in " ++ alignR maxn n1 ++ "|" ++ c1 ++ induced + | first&& not(isSyn r2) = "get from above " ++ alignR maxf "" ++ " " ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 + | last = "pass down " ++ alignR maxf f1 ++ "." ++ a1 ++ induced + | isSyn r2 = "get from below " ++ alignR maxf f2 ++ "." ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 + | isLocal r1 = if head a1 == '_' + then "" + else "calculate " ++ alignR maxf "loc" ++ "." ++ a1 + | otherwise = "pass down " ++ alignR maxf f1 ++ "." ++ alignL maxa a1 ++ " to " ++ alignR maxn n2 ++ "|" ++ c2 + where + first = v1<0 + last = v2<0 + r1 = ruleTable ! v1 + r2 = ruleTable ! v2 + a1 = show (getAttr r1) + a2 = show (getAttr r2) + f1 = show (getField r1) + f2 = show (getField r2) + n1 = show (getLhsNt r1) + n2 = show (getLhsNt r2) + c1 = show (getCon r1) + c2 = show (getCon r2) + induced | v2== -2 = " INDUCED dependency to " + | otherwise = "" + + +maxWidths ruleTable vs + = map maximum (transpose (map getWidth vs)) + where getWidth v | v<0 = [0,0,0,0] + | otherwise = map (length . show . ($ (ruleTable!v))) [getField, getAttr, getLhsNt, getCon] + +alignL n xs | k Bool -> Route -> Error +localCycleErr ruleTable o_visit (s:path) + = let cr = ruleTable ! s + attr = getAttr cr + nt = getLhsNt cr + con = getCon cr + in LocalCirc nt con attr o_visit (showPathLocal ruleTable path) + +instCycleErr :: Table CRule -> Bool -> Route -> Error +instCycleErr ruleTable o_visit (s:path) + = let cr = ruleTable ! s + attr = getAttr cr + nt = getLhsNt cr + con = getCon cr + in InstCirc nt con attr o_visit (showPathLocal ruleTable path) + +directCycleErrs :: Table NTAttr -> Table CRule -> Bool -> [EdgeRoutes] -> [Error] +directCycleErrs attrTable ruleTable o_visit xs + = let getNont v = case attrTable ! v of + NTASyn nt _ _ -> nt + NTAInh nt _ _ -> nt + getAttr v = case attrTable ! v of + NTASyn _ a _ -> a + NTAInh _ a _ -> a + sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 + procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) + wrapGroup gr@(((v1,_),_,_):_) = DirectCirc (getNont v1) o_visit (map procCycle gr) + in map wrapGroup (groupBy sameNont xs) + +inducedCycleErrs :: Table NTAttr -> Table CRule -> CInterfaceMap -> [EdgeRoutes] -> [Error] +inducedCycleErrs attrTable ruleTable cim xs + = let getNont v = case attrTable ! v of + NTASyn nt _ _ -> nt + NTAInh nt _ _ -> nt + getAttr v = case attrTable ! v of + NTASyn _ a _ -> a + NTAInh _ a _ -> a + sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 + procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) + wrapGroup gr@(((v1,_),_,_):_) = InducedCirc (getNont v1) (findWithErr1 "inducedCycleErr.cinter" (getNont v1) cim) (map procCycle gr) + in map wrapGroup (groupBy sameNont xs) {-# LINE 229 "src-generated/Order.hs" #-} -- Child ------------------------------------------------------- -- wrapper diff --git a/src-generated/Patterns.hs b/src-generated/Patterns.hs --- a/src-generated/Patterns.hs +++ b/src-generated/Patterns.hs @@ -3,10 +3,10 @@ -- UUAGC 0.9.53 (src-ag/Patterns.ag) module Patterns where {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 11 "src-generated/Patterns.hs" #-} -- Pattern ----------------------------------------------------- {- diff --git a/src-generated/PrintCleanCode.hs b/src-generated/PrintCleanCode.hs --- a/src-generated/PrintCleanCode.hs +++ b/src-generated/PrintCleanCode.hs @@ -4,117 +4,117 @@ module PrintCleanCode where {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 12 "src-generated/PrintCleanCode.hs" #-} {-# LINE 2 "src-ag/Code.ag" #-} - -import Patterns -import Data.Set(Set) -import qualified Data.Set as Set -import Data.Map(Map) -import qualified Data.Map as Map + +import Patterns +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Map(Map) +import qualified Data.Map as Map {-# LINE 21 "src-generated/PrintCleanCode.hs" #-} {-# LINE 10 "src-ag/PrintCleanCode.ag" #-} - -import Data.Char (isAlphaNum) -import Pretty -import Code -import Options -import CommonTypes (attrname, _LOC, nullIdent) -import Data.List(intersperse) -import System.IO -import System.Directory -import System.FilePath -import CommonTypes(BlockInfo, BlockKind(..)) + +import Data.Char (isAlphaNum) +import Pretty +import Code +import Options +import CommonTypes (attrname, _LOC, nullIdent) +import Data.List(intersperse) +import System.IO +import System.Directory +import System.FilePath +import CommonTypes(BlockInfo, BlockKind(..)) {-# LINE 35 "src-generated/PrintCleanCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 146 "src-ag/Code.ag" #-} - --- Unboxed tuples --- unbox Whether unboxed tuples are wanted or not --- inh The inherited attributes. --- If there are none, no unboxing can take place, --- because in that case the semantic function (a top-level identifier) would have an unboxed type. --- Of course we can't have an unboxed 1-tuple -mkTupleExpr :: Bool -> Bool -> Exprs -> Expr -mkTupleExpr unbox' noInh exprs | not unbox' || noInh || length exprs == 1 = TupleExpr exprs - | otherwise = UnboxedTupleExpr exprs -mkTupleType :: Bool -> Bool -> Types -> Type -mkTupleType unbox' noInh tps | not unbox' || noInh || length tps == 1 = TupleType tps - | otherwise = UnboxedTupleType tps -mkTupleLhs :: Bool -> Bool -> [String] -> Lhs -mkTupleLhs unbox' noInh comps | not unbox' || noInh || length comps == 1 = TupleLhs comps - | otherwise = UnboxedTupleLhs comps + +-- Unboxed tuples +-- unbox Whether unboxed tuples are wanted or not +-- inh The inherited attributes. +-- If there are none, no unboxing can take place, +-- because in that case the semantic function (a top-level identifier) would have an unboxed type. +-- Of course we can't have an unboxed 1-tuple +mkTupleExpr :: Bool -> Bool -> Exprs -> Expr +mkTupleExpr unbox' noInh exprs | not unbox' || noInh || length exprs == 1 = TupleExpr exprs + | otherwise = UnboxedTupleExpr exprs +mkTupleType :: Bool -> Bool -> Types -> Type +mkTupleType unbox' noInh tps | not unbox' || noInh || length tps == 1 = TupleType tps + | otherwise = UnboxedTupleType tps +mkTupleLhs :: Bool -> Bool -> [String] -> Lhs +mkTupleLhs unbox' noInh comps | not unbox' || noInh || length comps == 1 = TupleLhs comps + | otherwise = UnboxedTupleLhs comps {-# LINE 55 "src-generated/PrintCleanCode.hs" #-} {-# LINE 23 "src-ag/PrintCleanCode.ag" #-} - -type PP_Docs = [PP_Doc] + +type PP_Docs = [PP_Doc] {-# LINE 60 "src-generated/PrintCleanCode.hs" #-} {-# LINE 27 "src-ag/PrintCleanCode.ag" #-} - -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs + +ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqH = ppMultiSeq' (>#<) + +ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqV = ppMultiSeq' (>-<) + +ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeq' next strictArgs expr + = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs {-# LINE 73 "src-generated/PrintCleanCode.hs" #-} {-# LINE 322 "src-ag/PrintCleanCode.ag" #-} - - -reallySimple :: String -> Bool -reallySimple = and . map (\x -> isAlphaNum x || x=='_') - -ppTuple :: Bool -> [PP_Doc] -> PP_Doc -ppTuple _ [x] = pp x -ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps -ppTuple False pps = "(" >|< pp_block " " ")" "," pps -ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc -ppUnboxedTuple = ppTuple ---ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps ---ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps - + + +reallySimple :: String -> Bool +reallySimple = and . map (\x -> isAlphaNum x || x=='_') + +ppTuple :: Bool -> [PP_Doc] -> PP_Doc +ppTuple _ [x] = pp x +ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps +ppTuple False pps = "(" >|< pp_block " " ")" "," pps +ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc +ppUnboxedTuple = ppTuple +--ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps +--ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps + {-# LINE 90 "src-generated/PrintCleanCode.hs" #-} {-# LINE 425 "src-ag/PrintCleanCode.ag" #-} - -locname' :: Identifier -> [Char] -locname' n = "_loc_" ++ getName n + +locname' :: Identifier -> [Char] +locname' n = "_loc_" ++ getName n {-# LINE 96 "src-generated/PrintCleanCode.hs" #-} {-# LINE 500 "src-ag/PrintCleanCode.ag" #-} - -renderDocs :: [PP_Doc] -> String -renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" + +renderDocs :: [PP_Doc] -> String +renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" {-# LINE 102 "src-generated/PrintCleanCode.hs" #-} {-# LINE 548 "src-ag/PrintCleanCode.ag" #-} - -writeModule :: FilePath -> [PP_Doc] -> IO () -writeModule path docs - = do bExists <- doesFileExist path - if bExists - then do input <- readFile path - seq (length input) (return ()) - if input /= output - then dumpIt - else return () - else dumpIt - where - output = renderDocs docs - dumpIt = writeFile path output + +writeModule :: FilePath -> [PP_Doc] -> IO () +writeModule path docs + = do bExists <- doesFileExist path + if bExists + then do input <- readFile path + seq (length input) (return ()) + if input /= output + then dumpIt + else return () + else dumpIt + where + output = renderDocs docs + dumpIt = writeFile path output {-# LINE 119 "src-generated/PrintCleanCode.hs" #-} -- CaseAlt ----------------------------------------------------- -- wrapper diff --git a/src-generated/PrintCode.hs b/src-generated/PrintCode.hs --- a/src-generated/PrintCode.hs +++ b/src-generated/PrintCode.hs @@ -4,115 +4,115 @@ module PrintCode where {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 12 "src-generated/PrintCode.hs" #-} {-# LINE 2 "src-ag/Code.ag" #-} - -import Patterns -import Data.Set(Set) -import qualified Data.Set as Set -import Data.Map(Map) -import qualified Data.Map as Map + +import Patterns +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Map(Map) +import qualified Data.Map as Map {-# LINE 21 "src-generated/PrintCode.hs" #-} {-# LINE 10 "src-ag/PrintCode.ag" #-} - -import Data.Char (isAlphaNum) -import Pretty -import Code -import Options -import CommonTypes (attrname, _LOC, nullIdent) -import Data.List(intersperse) -import System.IO -import System.Directory -import System.FilePath -import CommonTypes(BlockInfo, BlockKind(..)) + +import Data.Char (isAlphaNum) +import Pretty +import Code +import Options +import CommonTypes (attrname, _LOC, nullIdent) +import Data.List(intersperse) +import System.IO +import System.Directory +import System.FilePath +import CommonTypes(BlockInfo, BlockKind(..)) {-# LINE 35 "src-generated/PrintCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 146 "src-ag/Code.ag" #-} - --- Unboxed tuples --- unbox Whether unboxed tuples are wanted or not --- inh The inherited attributes. --- If there are none, no unboxing can take place, --- because in that case the semantic function (a top-level identifier) would have an unboxed type. --- Of course we can't have an unboxed 1-tuple -mkTupleExpr :: Bool -> Bool -> Exprs -> Expr -mkTupleExpr unbox' noInh exprs | not unbox' || noInh || length exprs == 1 = TupleExpr exprs - | otherwise = UnboxedTupleExpr exprs -mkTupleType :: Bool -> Bool -> Types -> Type -mkTupleType unbox' noInh tps | not unbox' || noInh || length tps == 1 = TupleType tps - | otherwise = UnboxedTupleType tps -mkTupleLhs :: Bool -> Bool -> [String] -> Lhs -mkTupleLhs unbox' noInh comps | not unbox' || noInh || length comps == 1 = TupleLhs comps - | otherwise = UnboxedTupleLhs comps + +-- Unboxed tuples +-- unbox Whether unboxed tuples are wanted or not +-- inh The inherited attributes. +-- If there are none, no unboxing can take place, +-- because in that case the semantic function (a top-level identifier) would have an unboxed type. +-- Of course we can't have an unboxed 1-tuple +mkTupleExpr :: Bool -> Bool -> Exprs -> Expr +mkTupleExpr unbox' noInh exprs | not unbox' || noInh || length exprs == 1 = TupleExpr exprs + | otherwise = UnboxedTupleExpr exprs +mkTupleType :: Bool -> Bool -> Types -> Type +mkTupleType unbox' noInh tps | not unbox' || noInh || length tps == 1 = TupleType tps + | otherwise = UnboxedTupleType tps +mkTupleLhs :: Bool -> Bool -> [String] -> Lhs +mkTupleLhs unbox' noInh comps | not unbox' || noInh || length comps == 1 = TupleLhs comps + | otherwise = UnboxedTupleLhs comps {-# LINE 55 "src-generated/PrintCode.hs" #-} {-# LINE 23 "src-ag/PrintCode.ag" #-} - -type PP_Docs = [PP_Doc] + +type PP_Docs = [PP_Doc] {-# LINE 60 "src-generated/PrintCode.hs" #-} {-# LINE 27 "src-ag/PrintCode.ag" #-} - -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs + +ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqH = ppMultiSeq' (>#<) + +ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqV = ppMultiSeq' (>-<) + +ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeq' next strictArgs expr + = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs {-# LINE 73 "src-generated/PrintCode.hs" #-} {-# LINE 303 "src-ag/PrintCode.ag" #-} - - -reallySimple :: String -> Bool -reallySimple = and . map (\x -> isAlphaNum x || x=='_') - -ppTuple :: Bool -> [PP_Doc] -> PP_Doc -ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps -ppTuple False pps = "(" >|< pp_block " " ")" "," pps -ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc -ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps -ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps - + + +reallySimple :: String -> Bool +reallySimple = and . map (\x -> isAlphaNum x || x=='_') + +ppTuple :: Bool -> [PP_Doc] -> PP_Doc +ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps +ppTuple False pps = "(" >|< pp_block " " ")" "," pps +ppUnboxedTuple :: Bool -> [PP_Doc] -> PP_Doc +ppUnboxedTuple True pps = "(# " >|< pp_block " " (concat $ replicate (length pps `max` 1) " #)") ",(# " pps +ppUnboxedTuple False pps = "(# " >|< pp_block " " " #)" "," pps + {-# LINE 88 "src-generated/PrintCode.hs" #-} {-# LINE 404 "src-ag/PrintCode.ag" #-} - -locname' :: Identifier -> [Char] -locname' n = "_loc_" ++ getName n + +locname' :: Identifier -> [Char] +locname' n = "_loc_" ++ getName n {-# LINE 94 "src-generated/PrintCode.hs" #-} {-# LINE 479 "src-ag/PrintCode.ag" #-} - -renderDocs :: [PP_Doc] -> String -renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" + +renderDocs :: [PP_Doc] -> String +renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) "" {-# LINE 100 "src-generated/PrintCode.hs" #-} {-# LINE 527 "src-ag/PrintCode.ag" #-} - -writeModule :: FilePath -> [PP_Doc] -> IO () -writeModule path docs - = do bExists <- doesFileExist path - if bExists - then do input <- readFile path - seq (length input) (return ()) - if input /= output - then dumpIt - else return () - else dumpIt - where - output = renderDocs docs - dumpIt = writeFile path output + +writeModule :: FilePath -> [PP_Doc] -> IO () +writeModule path docs + = do bExists <- doesFileExist path + if bExists + then do input <- readFile path + seq (length input) (return ()) + if input /= output + then dumpIt + else return () + else dumpIt + where + output = renderDocs docs + dumpIt = writeFile path output {-# LINE 117 "src-generated/PrintCode.hs" #-} -- CaseAlt ----------------------------------------------------- -- wrapper diff --git a/src-generated/PrintErrorMessages.hs b/src-generated/PrintErrorMessages.hs --- a/src-generated/PrintErrorMessages.hs +++ b/src-generated/PrintErrorMessages.hs @@ -3,182 +3,182 @@ module PrintErrorMessages where {-# LINE 2 "src-ag/ErrorMessages.ag" #-} - -import UU.Scanner.Position(Pos) -import Pretty -import CodeSyntax -import CommonTypes + +import UU.Scanner.Position(Pos) +import Pretty +import CodeSyntax +import CommonTypes {-# LINE 12 "src-generated/PrintErrorMessages.hs" #-} {-# LINE 4 "src-ag/PrintErrorMessages.ag" #-} - -import UU.Scanner.Position(Pos(..), noPos) -import ErrorMessages -import Data.List(mapAccumL) -import GrammarInfo -import qualified Control.Monad.Error.Class as Err + +import UU.Scanner.Position(Pos(..), noPos) +import ErrorMessages +import Data.List(mapAccumL) +import GrammarInfo +import qualified Control.Monad.Error.Class as Err {-# LINE 21 "src-generated/PrintErrorMessages.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 13 "src-ag/PrintErrorMessages.ag" #-} - -instance Err.Error Error where - noMsg = Err.strMsg "error" - strMsg = CustomError False noPos . pp + +instance Err.Error Error where + noMsg = Err.strMsg "error" + strMsg = CustomError False noPos . pp {-# LINE 29 "src-generated/PrintErrorMessages.hs" #-} {-# LINE 20 "src-ag/PrintErrorMessages.ag" #-} - -isError :: Options -> Error -> Bool -isError _ (ParserError _ _ _ ) = True -isError _ (DupAlt _ _ _ ) = False -isError _ (DupSynonym _ _ ) = False -isError _ (DupSet _ _ ) = False -isError _ (DupInhAttr _ _ _ ) = True -isError _ (DupSynAttr _ _ _ ) = True -isError _ (DupChild _ _ _ _ ) = False -isError _ (DupRule _ _ _ _ _) = True -isError _ (DupSig _ _ _ ) = False -isError _ (UndefNont _ ) = True -isError _ (UndefAlt _ _ ) = True -isError _ (UndefChild _ _ _ ) = True -isError _ (MissingRule _ _ _ _ ) = False -isError _ (SuperfluousRule _ _ _ _ ) = False -isError _ (UndefLocal _ _ _ ) = True -isError _ (ChildAsLocal _ _ _ ) = False -isError _ (UndefAttr _ _ _ _ _) = True -isError _ (CyclicSet _ ) = True -isError _ (CustomError w _ _ ) = not w -isError opts (LocalCirc _ _ _ _ _) = cycleIsDangerous opts -isError opts (InstCirc _ _ _ _ _) = cycleIsDangerous opts -isError opts (DirectCirc _ _ _ ) = cycleIsDangerous opts -isError opts (InducedCirc _ _ _ ) = cycleIsDangerous opts -isError _ (MissingTypeSig _ _ _ ) = False -isError _ (MissingInstSig _ _ _ ) = True -isError _ (DupUnique _ _ _ ) = False -isError _ (MissingUnique _ _ ) = True -isError _ (MissingSyn _ _ ) = True -isError _ (MissingNamedRule _ _ _) = True -isError _ (DupRuleName _ _ _) = True -isError _ (HsParseError _ _) = True -isError _ (Cyclic _ _ _) = True -isError _ (IncompatibleVisitKind _ _ _ _) = True -isError _ (IncompatibleRuleKind _ _) = True -isError _ (IncompatibleAttachKind _ _) = True - -cycleIsDangerous :: Options -> Bool -cycleIsDangerous opts - = any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ] + +isError :: Options -> Error -> Bool +isError _ (ParserError _ _ _ ) = True +isError _ (DupAlt _ _ _ ) = False +isError _ (DupSynonym _ _ ) = False +isError _ (DupSet _ _ ) = False +isError _ (DupInhAttr _ _ _ ) = True +isError _ (DupSynAttr _ _ _ ) = True +isError _ (DupChild _ _ _ _ ) = False +isError _ (DupRule _ _ _ _ _) = True +isError _ (DupSig _ _ _ ) = False +isError _ (UndefNont _ ) = True +isError _ (UndefAlt _ _ ) = True +isError _ (UndefChild _ _ _ ) = True +isError _ (MissingRule _ _ _ _ ) = False +isError _ (SuperfluousRule _ _ _ _ ) = False +isError _ (UndefLocal _ _ _ ) = True +isError _ (ChildAsLocal _ _ _ ) = False +isError _ (UndefAttr _ _ _ _ _) = True +isError _ (CyclicSet _ ) = True +isError _ (CustomError w _ _ ) = not w +isError opts (LocalCirc _ _ _ _ _) = cycleIsDangerous opts +isError opts (InstCirc _ _ _ _ _) = cycleIsDangerous opts +isError opts (DirectCirc _ _ _ ) = cycleIsDangerous opts +isError opts (InducedCirc _ _ _ ) = cycleIsDangerous opts +isError _ (MissingTypeSig _ _ _ ) = False +isError _ (MissingInstSig _ _ _ ) = True +isError _ (DupUnique _ _ _ ) = False +isError _ (MissingUnique _ _ ) = True +isError _ (MissingSyn _ _ ) = True +isError _ (MissingNamedRule _ _ _) = True +isError _ (DupRuleName _ _ _) = True +isError _ (HsParseError _ _) = True +isError _ (Cyclic _ _ _) = True +isError _ (IncompatibleVisitKind _ _ _ _) = True +isError _ (IncompatibleRuleKind _ _) = True +isError _ (IncompatibleAttachKind _ _) = True + +cycleIsDangerous :: Options -> Bool +cycleIsDangerous opts + = any ($ opts) [ wignore, bangpats, cases, strictCases, stricterCases, strictSems, withCycle ] {-# LINE 73 "src-generated/PrintErrorMessages.hs" #-} {-# LINE 548 "src-ag/PrintErrorMessages.ag" #-} - -toWidth :: Int -> String -> String -toWidth n xs | k PP_Doc -showEdge ((inh,syn),_,_) - = text ("inherited attribute " ++ toWidth 20 (getName inh) ++ " with synthesized attribute " ++ getName syn) - -showEdgeLong :: ((Identifier,Identifier),[String],[String]) -> PP_Doc -showEdgeLong ((inh,syn),path1,path2) - = text ("inherited attribute " ++ getName inh ++ " is needed for " ++ "synthesized attribute " ++ getName syn) - >-< indent 4 (vlist (map text path2)) - >-< text "and back: " - >-< indent 4 (vlist (map text path1)) - -attrText :: Identifier -> Identifier -> String -attrText inh syn - = if inh == syn - then "threaded attribute " ++ getName inh - else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn - -showLineNr :: Int -> String -showLineNr i | i==(-1) = "CR" - | otherwise = show i - -showAttrDef :: Identifier -> Identifier -> String -showAttrDef f a | f == _LHS = "synthesized attribute " ++ getName a - | f == _LOC = "local attribute " ++ getName a - | f == _INST = "inst attribute " ++ getName a - | otherwise = "inherited attribute " ++ getName a ++ " of field " ++ getName f - -showAttrUse :: Identifier -> Identifier -> String -showAttrUse f a | f == _LHS = "inherited attribute " ++ getName a - | f == _LOC = "local attribute " ++ getName a - | f == _INST = "inst attribute " ++ getName a - | otherwise = "synthesized attribute " ++ getName a ++ " of field " ++ getName f - -ppAttr :: Identifier -> Identifier -> PP_Doc -ppAttr f a = text (getName f++"."++getName a) -ppAttrUse :: Identifier -> Identifier -> PP_Doc -ppAttrUse f a = "@" >|< ppAttr f a + +toWidth :: Int -> String -> String +toWidth n xs | k PP_Doc +showEdge ((inh,syn),_,_) + = text ("inherited attribute " ++ toWidth 20 (getName inh) ++ " with synthesized attribute " ++ getName syn) + +showEdgeLong :: ((Identifier,Identifier),[String],[String]) -> PP_Doc +showEdgeLong ((inh,syn),path1,path2) + = text ("inherited attribute " ++ getName inh ++ " is needed for " ++ "synthesized attribute " ++ getName syn) + >-< indent 4 (vlist (map text path2)) + >-< text "and back: " + >-< indent 4 (vlist (map text path1)) + +attrText :: Identifier -> Identifier -> String +attrText inh syn + = if inh == syn + then "threaded attribute " ++ getName inh + else "inherited attribute " ++ getName inh ++ " and synthesized attribute " ++getName syn + +showLineNr :: Int -> String +showLineNr i | i==(-1) = "CR" + | otherwise = show i + +showAttrDef :: Identifier -> Identifier -> String +showAttrDef f a | f == _LHS = "synthesized attribute " ++ getName a + | f == _LOC = "local attribute " ++ getName a + | f == _INST = "inst attribute " ++ getName a + | otherwise = "inherited attribute " ++ getName a ++ " of field " ++ getName f + +showAttrUse :: Identifier -> Identifier -> String +showAttrUse f a | f == _LHS = "inherited attribute " ++ getName a + | f == _LOC = "local attribute " ++ getName a + | f == _INST = "inst attribute " ++ getName a + | otherwise = "synthesized attribute " ++ getName a ++ " of field " ++ getName f + +ppAttr :: Identifier -> Identifier -> PP_Doc +ppAttr f a = text (getName f++"."++getName a) +ppAttrUse :: Identifier -> Identifier -> PP_Doc +ppAttrUse f a = "@" >|< ppAttr f a {-# LINE 119 "src-generated/PrintErrorMessages.hs" #-} {-# LINE 594 "src-ag/PrintErrorMessages.ag" #-} - -infixr 5 +#+ -(+#+) :: String -> String -> String -(+#+) s t = s ++ " " ++ t - -infixr 5 +.+ -(+.+) :: Identifier -> Identifier -> String -(+.+) s t = getName s ++ "." ++ getName t - -wfill :: [String] -> PP_Doc -wfill = fill . addSpaces. concat . map words - where addSpaces (x:xs) = x:map addSpace xs - addSpaces [] = [] - addSpace [x] | x `elem` ".,;:!?" = [x] - addSpace xs = ' ':xs - -ppError :: Bool -- class of the error, True:error False:warning - -> Pos -- source position - -> PP_Doc -- error message - -> PP_Doc -- pattern - -> PP_Doc -- help, more info - -> PP_Doc -- action taken by AG - -> Bool -- verbose? show help and action? - -> PP_Doc -ppError isErr pos mesg pat hlp act verb - = let position = case pos of - Pos l c f | l >= 0 -> f >|< ":" >|< show l >|< ":" >|< show c - | otherwise -> pp "uuagc" - tp = if isErr then "error" else "warning" - header = position >|< ":" >#< tp >|< ":" >#< mesg - pattern = "pattern :" >#< pat - help = "help :" >#< hlp - action = "action :" >#< act - in if verb - then vlist [text "",header,pattern,help,action] - else header - -{- --- old error reporting code - = let - cl = if isError then "ERROR" else "Warning" - position = case pos of - (Pos l c f) | l >= 0 -> f >|< ": line " >|< show l >|< ", column " >|< show c - | otherwise -> empty - header = "*** UU.AG" >#< cl >#< position >#< "***" - message = "problem :" >#< mesg - pattern = "pattern :" >#< pat - help = "help :" >#< hlp - action = "action :" >#< act - in - if verbose - then vlist [text "",header,message,pattern,help,action] - else vlist [text "",header,message] --} - -showPos :: Identifier -> String -showPos = show . getPos - -ppInterface :: Show a => a -> PP_Doc -ppInterface inter = wfill ["interface:", show inter] - + +infixr 5 +#+ +(+#+) :: String -> String -> String +(+#+) s t = s ++ " " ++ t + +infixr 5 +.+ +(+.+) :: Identifier -> Identifier -> String +(+.+) s t = getName s ++ "." ++ getName t + +wfill :: [String] -> PP_Doc +wfill = fill . addSpaces. concat . map words + where addSpaces (x:xs) = x:map addSpace xs + addSpaces [] = [] + addSpace [x] | x `elem` ".,;:!?" = [x] + addSpace xs = ' ':xs + +ppError :: Bool -- class of the error, True:error False:warning + -> Pos -- source position + -> PP_Doc -- error message + -> PP_Doc -- pattern + -> PP_Doc -- help, more info + -> PP_Doc -- action taken by AG + -> Bool -- verbose? show help and action? + -> PP_Doc +ppError isErr pos mesg pat hlp act verb + = let position = case pos of + Pos l c f | l >= 0 -> f >|< ":" >|< show l >|< ":" >|< show c + | otherwise -> pp "uuagc" + tp = if isErr then "error" else "warning" + header = position >|< ":" >#< tp >|< ":" >#< mesg + pattern = "pattern :" >#< pat + help = "help :" >#< hlp + action = "action :" >#< act + in if verb + then vlist [text "",header,pattern,help,action] + else header + +{- +-- old error reporting code + = let + cl = if isError then "ERROR" else "Warning" + position = case pos of + (Pos l c f) | l >= 0 -> f >|< ": line " >|< show l >|< ", column " >|< show c + | otherwise -> empty + header = "*** UU.AG" >#< cl >#< position >#< "***" + message = "problem :" >#< mesg + pattern = "pattern :" >#< pat + help = "help :" >#< hlp + action = "action :" >#< act + in + if verbose + then vlist [text "",header,message,pattern,help,action] + else vlist [text "",header,message] +-} + +showPos :: Identifier -> String +showPos = show . getPos + +ppInterface :: Show a => a -> PP_Doc +ppInterface inter = wfill ["interface:", show inter] + {-# LINE 183 "src-generated/PrintErrorMessages.hs" #-} -- Error ------------------------------------------------------- -- wrapper diff --git a/src-generated/PrintOcamlCode.hs b/src-generated/PrintOcamlCode.hs --- a/src-generated/PrintOcamlCode.hs +++ b/src-generated/PrintOcamlCode.hs @@ -4,76 +4,76 @@ module PrintOcamlCode where {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 12 "src-generated/PrintOcamlCode.hs" #-} {-# LINE 2 "src-ag/Code.ag" #-} - -import Patterns -import Data.Set(Set) -import qualified Data.Set as Set -import Data.Map(Map) -import qualified Data.Map as Map + +import Patterns +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Map(Map) +import qualified Data.Map as Map {-# LINE 21 "src-generated/PrintOcamlCode.hs" #-} {-# LINE 10 "src-ag/PrintOcamlCode.ag" #-} - -import Pretty -import Code -import Patterns -import Options -import CommonTypes hiding (List,Type,Map,Maybe,IntMap,Either) -import Data.List(intersperse,intercalate) -import Data.Char(toLower) + +import Pretty +import Code +import Patterns +import Options +import CommonTypes hiding (List,Type,Map,Maybe,IntMap,Either) +import Data.List(intersperse,intercalate) +import Data.Char(toLower) {-# LINE 32 "src-generated/PrintOcamlCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 146 "src-ag/Code.ag" #-} - --- Unboxed tuples --- unbox Whether unboxed tuples are wanted or not --- inh The inherited attributes. --- If there are none, no unboxing can take place, --- because in that case the semantic function (a top-level identifier) would have an unboxed type. --- Of course we can't have an unboxed 1-tuple -mkTupleExpr :: Bool -> Bool -> Exprs -> Expr -mkTupleExpr unbox' noInh exprs | not unbox' || noInh || length exprs == 1 = TupleExpr exprs - | otherwise = UnboxedTupleExpr exprs -mkTupleType :: Bool -> Bool -> Types -> Type -mkTupleType unbox' noInh tps | not unbox' || noInh || length tps == 1 = TupleType tps - | otherwise = UnboxedTupleType tps -mkTupleLhs :: Bool -> Bool -> [String] -> Lhs -mkTupleLhs unbox' noInh comps | not unbox' || noInh || length comps == 1 = TupleLhs comps - | otherwise = UnboxedTupleLhs comps + +-- Unboxed tuples +-- unbox Whether unboxed tuples are wanted or not +-- inh The inherited attributes. +-- If there are none, no unboxing can take place, +-- because in that case the semantic function (a top-level identifier) would have an unboxed type. +-- Of course we can't have an unboxed 1-tuple +mkTupleExpr :: Bool -> Bool -> Exprs -> Expr +mkTupleExpr unbox' noInh exprs | not unbox' || noInh || length exprs == 1 = TupleExpr exprs + | otherwise = UnboxedTupleExpr exprs +mkTupleType :: Bool -> Bool -> Types -> Type +mkTupleType unbox' noInh tps | not unbox' || noInh || length tps == 1 = TupleType tps + | otherwise = UnboxedTupleType tps +mkTupleLhs :: Bool -> Bool -> [String] -> Lhs +mkTupleLhs unbox' noInh comps | not unbox' || noInh || length comps == 1 = TupleLhs comps + | otherwise = UnboxedTupleLhs comps {-# LINE 52 "src-generated/PrintOcamlCode.hs" #-} {-# LINE 21 "src-ag/PrintOcamlCode.ag" #-} - -type PP_Docs = [PP_Doc] - -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs - -ppTuple :: Bool -> [PP_Doc] -> PP_Doc -ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps -ppTuple False pps = "(" >|< pp_block " " ")" "," pps + +type PP_Docs = [PP_Doc] + +ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqH = ppMultiSeq' (>#<) + +ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqV = ppMultiSeq' (>-<) + +ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeq' next strictArgs expr + = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs + +ppTuple :: Bool -> [PP_Doc] -> PP_Doc +ppTuple True pps = "(" >|< pp_block " " (replicate (length pps `max` 1) ')') ",(" pps +ppTuple False pps = "(" >|< pp_block " " ")" "," pps {-# LINE 71 "src-generated/PrintOcamlCode.hs" #-} {-# LINE 177 "src-ag/PrintOcamlCode.ag" #-} - -toOcamlTC :: String -> String -toOcamlTC (c:cs) = toLower c : cs -toOcamlTC xs = xs + +toOcamlTC :: String -> String +toOcamlTC (c:cs) = toLower c : cs +toOcamlTC xs = xs {-# LINE 78 "src-generated/PrintOcamlCode.hs" #-} -- CaseAlt ----------------------------------------------------- -- wrapper diff --git a/src-generated/PrintVisitCode.hs b/src-generated/PrintVisitCode.hs --- a/src-generated/PrintVisitCode.hs +++ b/src-generated/PrintVisitCode.hs @@ -3,62 +3,62 @@ module PrintVisitCode where {-# LINE 2 "src-ag/DeclBlocks.ag" #-} - -import Code (Decl,Expr) + +import Code (Decl,Expr) {-# LINE 9 "src-generated/PrintVisitCode.hs" #-} {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 16 "src-generated/PrintVisitCode.hs" #-} {-# LINE 2 "src-ag/CodeSyntax.ag" #-} - -import Patterns -import CommonTypes -import Data.Map(Map) -import Data.Set(Set) + +import Patterns +import CommonTypes +import Data.Map(Map) +import Data.Set(Set) {-# LINE 24 "src-generated/PrintVisitCode.hs" #-} {-# LINE 10 "src-ag/PrintVisitCode.ag" #-} - -import CommonTypes -import SequentialTypes -import Options -import CodeSyntax -import ErrorMessages -import GrammarInfo -import DeclBlocks -import Pretty - -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Set as Set -import Data.Set(Set) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq) -import UU.Scanner.Position - -import Data.List(partition,intersperse,intersect,(\\)) -import Data.Maybe(fromJust,isJust) + +import CommonTypes +import SequentialTypes +import Options +import CodeSyntax +import ErrorMessages +import GrammarInfo +import DeclBlocks +import Pretty + +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Set as Set +import Data.Set(Set) +import qualified Data.Sequence as Seq +import Data.Sequence(Seq) +import UU.Scanner.Position + +import Data.List(partition,intersperse,intersect,(\\)) +import Data.Maybe(fromJust,isJust) {-# LINE 47 "src-generated/PrintVisitCode.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 32 "src-ag/PrintVisitCode.ag" #-} - -type PP_Docs = [PP_Doc] - -ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqH = ppMultiSeq' (>#<) - -ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeqV = ppMultiSeq' (>-<) - -ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc -ppMultiSeq' next strictArgs expr - = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs + +type PP_Docs = [PP_Doc] + +ppMultiSeqH :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqH = ppMultiSeq' (>#<) + +ppMultiSeqV :: [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeqV = ppMultiSeq' (>-<) + +ppMultiSeq' :: (PP_Doc -> PP_Doc -> PP_Doc) -> [PP_Doc] -> PP_Doc -> PP_Doc +ppMultiSeq' next strictArgs expr + = foldr (\v r -> (v >#< "`seq`") `next` pp_parens r) expr strictArgs {-# LINE 63 "src-generated/PrintVisitCode.hs" #-} -- CGrammar ---------------------------------------------------- -- wrapper diff --git a/src-generated/ResolveLocals.hs b/src-generated/ResolveLocals.hs --- a/src-generated/ResolveLocals.hs +++ b/src-generated/ResolveLocals.hs @@ -3,46 +3,46 @@ module ResolveLocals where {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 10 "src-generated/ResolveLocals.hs" #-} {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 17 "src-generated/ResolveLocals.hs" #-} {-# LINE 2 "src-ag/AbstractSyntax.ag" #-} - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import Macro --marcos -import CommonTypes -import ErrorMessages + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import Macro --marcos +import CommonTypes +import ErrorMessages {-# LINE 29 "src-generated/ResolveLocals.hs" #-} {-# LINE 15 "src-ag/ResolveLocals.ag" #-} - -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Map(Map) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq,(><)) -import CommonTypes -import Patterns -import ErrorMessages -import AbstractSyntax -import Expression -import Options -import HsToken(HsTokensRoot(HsTokensRoot)) -import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) -import Data.Maybe + +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.Map(Map) +import qualified Data.Sequence as Seq +import Data.Sequence(Seq,(><)) +import CommonTypes +import Patterns +import ErrorMessages +import AbstractSyntax +import Expression +import Options +import HsToken(HsTokensRoot(HsTokensRoot)) +import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) +import Data.Maybe {-# LINE 47 "src-generated/ResolveLocals.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity diff --git a/src-generated/SemHsTokens.hs b/src-generated/SemHsTokens.hs --- a/src-generated/SemHsTokens.hs +++ b/src-generated/SemHsTokens.hs @@ -3,28 +3,28 @@ module SemHsTokens where {-# LINE 2 "src-ag/HsToken.ag" #-} - -import CommonTypes -import UU.Scanner.Position(Pos) + +import CommonTypes +import UU.Scanner.Position(Pos) {-# LINE 10 "src-generated/SemHsTokens.hs" #-} {-# LINE 4 "src-ag/SemHsTokens.ag" #-} - -import qualified Data.Sequence as Seq -import Data.Sequence(Seq,empty,singleton,(><)) -import Data.Foldable(toList) -import Pretty - -import TokenDef -import HsToken -import ErrorMessages + +import qualified Data.Sequence as Seq +import Data.Sequence(Seq,empty,singleton,(><)) +import Data.Foldable(toList) +import Pretty + +import TokenDef +import HsToken +import ErrorMessages {-# LINE 22 "src-generated/SemHsTokens.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 58 "src-ag/SemHsTokens.ag" #-} - -isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts -isNTname allnts _ = False + +isNTname allnts (Just (NT nt _ _)) = nt `elem` allnts +isNTname allnts _ = False {-# LINE 29 "src-generated/SemHsTokens.hs" #-} -- HsToken ----------------------------------------------------- -- wrapper diff --git a/src-generated/TfmToMirage.hs b/src-generated/TfmToMirage.hs new file mode 100644 --- /dev/null +++ b/src-generated/TfmToMirage.hs @@ -0,0 +1,4130 @@ +{-# LANGUAGE Rank2Types, GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module TfmToMirage where +{-# LINE 2 "src-ag/Patterns.ag" #-} + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) +{-# LINE 11 "src-generated/TfmToMirage.hs" #-} + +{-# LINE 10 "src-ag/Order.ag" #-} + +-- From uuagc +import CommonTypes +import Patterns +import ErrorMessages +import AbstractSyntax +import Code hiding (Type) +import qualified Code +import Expression +import Options +import SequentialComputation +import SequentialTypes +import CodeSyntax +import GrammarInfo +import HsToken(HsTokensRoot(HsTokensRoot)) +import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) +-- From uulib +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Sequence as Seq +import Data.Map(Map) +import Data.Set(Set) +import Data.Sequence(Seq, (><)) +import UU.Util.Utils +import UU.Scanner.Position(Pos(..),initPos) +import Data.Foldable(toList) + +-- From haskell libraries +import Control.Monad(liftM) +import qualified Data.Array as Array +import Data.Array((!),bounds,inRange) +import Data.List(elemIndex,partition,sort,mapAccumL,find,nubBy,intersperse,groupBy,transpose) +import qualified Data.Tree as Tree +import Data.Maybe +{-# LINE 48 "src-generated/TfmToMirage.hs" #-} + +{-# LINE 2 "src-ag/Expression.ag" #-} + +import UU.Scanner.Position(Pos) +import HsToken +{-# LINE 54 "src-generated/TfmToMirage.hs" #-} + +{-# LINE 2 "src-ag/AbstractSyntax.ag" #-} + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import Macro --marcos +import CommonTypes +import ErrorMessages +{-# LINE 66 "src-generated/TfmToMirage.hs" #-} + +{-# LINE 5 "src-ag/TfmToMirage.ag" #-} + +import AbstractSyntax +import qualified Data.Map as Map +import Pretty +import TokenDef +import qualified MirageSyntax as Mirage +{-# LINE 75 "src-generated/TfmToMirage.hs" #-} +import Control.Monad.Identity (Identity) +import qualified Control.Monad.Identity +{-# LINE 46 "src-ag/Order.ag" #-} + +-- Terminates with an error if the key is not in the map +findWithErr1 :: (Ord k, Show k) => String -> k -> Map k a -> a +findWithErr1 s k + = Map.findWithDefault (error ("findWithErr1 " ++ s ++ ": key " ++ show k ++ " not in map.")) k + +findWithErr2 :: (Ord k, Show k, Show a) => k -> Map k a -> a +findWithErr2 k m + = Map.findWithDefault (error ("findWithErr2: key " ++ show k ++ " not in map: " ++ show m)) k m +{-# LINE 88 "src-generated/TfmToMirage.hs" #-} + +{-# LINE 71 "src-ag/Order.ag" #-} + +startsWith :: String -> String -> Bool +startsWith k h = k == take (length k) h +{-# LINE 94 "src-generated/TfmToMirage.hs" #-} + +{-# LINE 138 "src-ag/Order.ag" #-} + +getNtName :: Type -> NontermIdent +getNtName (NT nt _ _) = nt +getNtName _ = nullIdent +{-# LINE 101 "src-generated/TfmToMirage.hs" #-} + +{-# LINE 166 "src-ag/Order.ag" #-} + +data AltAttr = AltAttr Identifier Identifier Bool + deriving (Eq, Ord, Show) +{-# LINE 107 "src-generated/TfmToMirage.hs" #-} + +{-# LINE 239 "src-ag/Order.ag" #-} + +substSelf nt tp + = case tp of + NT n tps defor | n == _SELF -> NT nt tps defor + _ -> tp + +haskellTupel :: [Type] -> Maybe Type +haskellTupel ts = Just ( Haskell ( '(' : (concat (intersperse "," (map show ts))) ++ ")" )) +{-# LINE 118 "src-generated/TfmToMirage.hs" #-} + +{-# LINE 692 "src-ag/Order.ag" #-} + +swap (a,b) = (b,a) + +showPath :: Table CRule -> [Vertex] -> [String] +showPath ruleTable path + = let look a | inRange (bounds ruleTable) a = [showOrigin (ruleTable ! a)] + | otherwise = ["Vertex " ++ show a] + showOrigin cr | getHasCode cr && getName (getAttr cr) /= "self" = prettyCRule cr ++ " (" ++ show (getPos (getAttr cr)) ++ ")" + | otherwise = prettyCRule cr + in concatMap look path + + +showPathLocal :: Table CRule -> [Vertex] -> [String] +showPathLocal _ [] = [] +showPathLocal ruleTable xs = showP (xs++[-1]) + where showP [] = [] + showP (v1:v2:vs) = let line = step v1 v2 + lines = showP vs + in line:lines + step v1 v2 = " - " ++ a1 + where r1 = ruleTable ! v1 + a1 = show (getAttr r1) + + +limitTo :: Int -> [String] -> [String] +limitTo _ [] = [] +limitTo 0 _ = ["....etcetera, etcetera...."] +limitTo n (x:xs) = x : limitTo (n-1) xs + +showPathNice :: Table CRule -> [Vertex] -> [String] +showPathNice _ [] = [] +showPathNice ruleTable xs = limitTo 100 (showP ((-1):xs++[-1])) + where [maxf, maxa, maxn, maxc] = maxWidths ruleTable (take 100 xs) + showP [] = [] + showP (v1:v2:vs) = let line = step v1 v2 + lines = showP vs + in if null line then lines else line:lines + step v1 v2 | last && first = induced + | last && isSyn r1 = "pass up " ++ alignR maxf "" ++ " " ++ alignL maxa a1 ++ " in " ++ alignR maxn n1 ++ "|" ++ c1 ++ induced + | first&& not(isSyn r2) = "get from above " ++ alignR maxf "" ++ " " ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 + | last = "pass down " ++ alignR maxf f1 ++ "." ++ a1 ++ induced + | isSyn r2 = "get from below " ++ alignR maxf f2 ++ "." ++ alignL maxa a2 ++ " in " ++ alignR maxn n2 ++ "|" ++ c2 + | isLocal r1 = if head a1 == '_' + then "" + else "calculate " ++ alignR maxf "loc" ++ "." ++ a1 + | otherwise = "pass down " ++ alignR maxf f1 ++ "." ++ alignL maxa a1 ++ " to " ++ alignR maxn n2 ++ "|" ++ c2 + where + first = v1<0 + last = v2<0 + r1 = ruleTable ! v1 + r2 = ruleTable ! v2 + a1 = show (getAttr r1) + a2 = show (getAttr r2) + f1 = show (getField r1) + f2 = show (getField r2) + n1 = show (getLhsNt r1) + n2 = show (getLhsNt r2) + c1 = show (getCon r1) + c2 = show (getCon r2) + induced | v2== -2 = " INDUCED dependency to " + | otherwise = "" + + +maxWidths ruleTable vs + = map maximum (transpose (map getWidth vs)) + where getWidth v | v<0 = [0,0,0,0] + | otherwise = map (length . show . ($ (ruleTable!v))) [getField, getAttr, getLhsNt, getCon] + +alignL n xs | k Bool -> Route -> Error +localCycleErr ruleTable o_visit (s:path) + = let cr = ruleTable ! s + attr = getAttr cr + nt = getLhsNt cr + con = getCon cr + in LocalCirc nt con attr o_visit (showPathLocal ruleTable path) + +instCycleErr :: Table CRule -> Bool -> Route -> Error +instCycleErr ruleTable o_visit (s:path) + = let cr = ruleTable ! s + attr = getAttr cr + nt = getLhsNt cr + con = getCon cr + in InstCirc nt con attr o_visit (showPathLocal ruleTable path) + +directCycleErrs :: Table NTAttr -> Table CRule -> Bool -> [EdgeRoutes] -> [Error] +directCycleErrs attrTable ruleTable o_visit xs + = let getNont v = case attrTable ! v of + NTASyn nt _ _ -> nt + NTAInh nt _ _ -> nt + getAttr v = case attrTable ! v of + NTASyn _ a _ -> a + NTAInh _ a _ -> a + sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 + procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) + wrapGroup gr@(((v1,_),_,_):_) = DirectCirc (getNont v1) o_visit (map procCycle gr) + in map wrapGroup (groupBy sameNont xs) + +inducedCycleErrs :: Table NTAttr -> Table CRule -> CInterfaceMap -> [EdgeRoutes] -> [Error] +inducedCycleErrs attrTable ruleTable cim xs + = let getNont v = case attrTable ! v of + NTASyn nt _ _ -> nt + NTAInh nt _ _ -> nt + getAttr v = case attrTable ! v of + NTASyn _ a _ -> a + NTAInh _ a _ -> a + sameNont ((v1,_),_,_) ((v2,_),_,_) = getNont v1 == getNont v2 + procCycle ((v1,v2),p1,p2) = ((getAttr v1, getAttr v2), showPathNice ruleTable p1, showPathNice ruleTable p2) + wrapGroup gr@(((v1,_),_,_):_) = InducedCirc (getNont v1) (findWithErr1 "inducedCycleErr.cinter" (getNont v1) cim) (map procCycle gr) + in map wrapGroup (groupBy sameNont xs) +{-# LINE 238 "src-generated/TfmToMirage.hs" #-} + +{-# LINE 13 "src-ag/TfmToMirage.ag" #-} + +typeToMirage :: Type -> Mirage.Type +typeToMirage x = case x of + Haskell y -> Mirage.Haskell y + NT y ys _ -> Mirage.NT (getName y) ys + Self -> Mirage.Self +{-# LINE 247 "src-generated/TfmToMirage.hs" #-} +-- Child ------------------------------------------------------- +-- wrapper +data Inh_Child = Inh_Child { allfields_Inh_Child :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Child :: ([Identifier]), attrs_Inh_Child :: ([(Identifier,Identifier)]), con_Inh_Child :: (Identifier), inh_Inh_Child :: (Attributes), inhMap_Inh_Child :: (Map Identifier Attributes), mergeMap_Inh_Child :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Child :: (Identifier), o_unbox_Inh_Child :: (Bool), syn_Inh_Child :: (Attributes), synMap_Inh_Child :: (Map Identifier Attributes) } +data Syn_Child = Syn_Child { attributes_Syn_Child :: ([(Identifier,Attributes,Attributes)]), collectChildrenInhs_Syn_Child :: (Map Identifier Attributes ), collectChildrenSyns_Syn_Child :: (Map Identifier Attributes ), errors_Syn_Child :: (Seq Error), field_Syn_Child :: ((Identifier,Type,ChildKind)), gathAltAttrs_Syn_Child :: ([AltAttr]), gathRules_Syn_Child :: (Seq CRule), inhs_Syn_Child :: (Seq (Identifier,Attributes)), mirage_Syn_Child :: (Mirage.Child), nts_Syn_Child :: (Seq (Identifier,NontermIdent)), singlevisits_Syn_Child :: ([CRule]), terminals_Syn_Child :: ([Identifier]) } +{-# INLINABLE wrap_Child #-} +wrap_Child :: T_Child -> Inh_Child -> (Syn_Child ) +wrap_Child (T_Child act) (Inh_Child _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg1 = T_Child_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap + (T_Child_vOut1 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfield _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirage _lhsOnts _lhsOsinglevisits _lhsOterminals) <- return (inv_Child_s2 sem arg1) + return (Syn_Child _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfield _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirage _lhsOnts _lhsOsinglevisits _lhsOterminals) + ) + +-- cata +{-# INLINE sem_Child #-} +sem_Child :: Child -> T_Child +sem_Child ( Child name_ tp_ kind_ ) = sem_Child_Child name_ tp_ kind_ + +-- semantic domain +newtype T_Child = T_Child { + attach_T_Child :: Identity (T_Child_s2 ) + } +newtype T_Child_s2 = C_Child_s2 { + inv_Child_s2 :: (T_Child_v1 ) + } +data T_Child_s3 = C_Child_s3 +type T_Child_v1 = (T_Child_vIn1 ) -> (T_Child_vOut1 ) +data T_Child_vIn1 = T_Child_vIn1 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Bool) (Attributes) (Map Identifier Attributes) +data T_Child_vOut1 = T_Child_vOut1 ([(Identifier,Attributes,Attributes)]) (Map Identifier Attributes ) (Map Identifier Attributes ) (Seq Error) ((Identifier,Type,ChildKind)) ([AltAttr]) (Seq CRule) (Seq (Identifier,Attributes)) (Mirage.Child) (Seq (Identifier,NontermIdent)) ([CRule]) ([Identifier]) +{-# NOINLINE sem_Child_Child #-} +sem_Child_Child :: (Identifier) -> (Type) -> (ChildKind) -> T_Child +sem_Child_Child arg_name_ arg_tp_ arg_kind_ = T_Child (return st2) where + {-# NOINLINE st2 #-} + st2 = let + v1 :: T_Child_v1 + v1 = \ (T_Child_vIn1 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) -> ( let + _chnt = rule0 arg_name_ arg_tp_ + _inh = rule1 _chnt _lhsIinhMap + _syn = rule2 _chnt _lhsIsynMap + _maptolocal = rule3 _syn arg_tp_ + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule4 _maptolocal _syn arg_name_ + _lhsOnts :: Seq (Identifier,NontermIdent) + _lhsOnts = rule5 arg_name_ arg_tp_ + _lhsOinhs :: Seq (Identifier,Attributes) + _lhsOinhs = rule6 _inh arg_name_ + _gathRules = rule7 _lhsIcon _lhsInt _maptolocal _syn arg_name_ arg_tp_ + _lhsOcollectChildrenSyns :: Map Identifier Attributes + _lhsOcollectChildrenSyns = rule8 _syn arg_name_ + _lhsOcollectChildrenInhs :: Map Identifier Attributes + _lhsOcollectChildrenInhs = rule9 _inh arg_name_ + _lhsOsinglevisits :: [CRule] + _lhsOsinglevisits = rule10 _inh _maptolocal _syn arg_name_ arg_tp_ + _lhsOterminals :: [Identifier] + _lhsOterminals = rule11 _maptolocal arg_name_ + _lhsOattributes :: [(Identifier,Attributes,Attributes)] + _lhsOattributes = rule12 _inh _syn arg_name_ + _lhsOfield :: (Identifier,Type,ChildKind) + _lhsOfield = rule13 arg_kind_ arg_name_ arg_tp_ + _lhsOmirage :: Mirage.Child + _lhsOmirage = rule14 arg_name_ arg_tp_ + _lhsOerrors :: Seq Error + _lhsOerrors = rule15 () + _lhsOgathRules :: Seq CRule + _lhsOgathRules = rule16 _gathRules + __result_ = T_Child_vOut1 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfield _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirage _lhsOnts _lhsOsinglevisits _lhsOterminals + in __result_ ) + in C_Child_s2 v1 + {-# INLINE rule0 #-} + {-# LINE 19 "src-ag/DistChildAttr.ag" #-} + rule0 = \ name_ tp_ -> + {-# LINE 19 "src-ag/DistChildAttr.ag" #-} + case tp_ of + NT nt _ _ -> nt + Self -> error ("The type of child " ++ show name_ ++ " should not be a Self type.") + Haskell t -> identifier "" + {-# LINE 325 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule1 #-} + {-# LINE 23 "src-ag/DistChildAttr.ag" #-} + rule1 = \ _chnt ((_lhsIinhMap) :: Map Identifier Attributes) -> + {-# LINE 23 "src-ag/DistChildAttr.ag" #-} + Map.findWithDefault Map.empty _chnt _lhsIinhMap + {-# LINE 331 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule2 #-} + {-# LINE 24 "src-ag/DistChildAttr.ag" #-} + rule2 = \ _chnt ((_lhsIsynMap) :: Map Identifier Attributes) -> + {-# LINE 24 "src-ag/DistChildAttr.ag" #-} + Map.findWithDefault Map.empty _chnt _lhsIsynMap + {-# LINE 337 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule3 #-} + {-# LINE 180 "src-ag/Order.ag" #-} + rule3 = \ _syn tp_ -> + {-# LINE 180 "src-ag/Order.ag" #-} + case tp_ of + NT nt _ _ -> Map.null _syn + _ -> True + {-# LINE 345 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule4 #-} + {-# LINE 183 "src-ag/Order.ag" #-} + rule4 = \ _maptolocal _syn name_ -> + {-# LINE 183 "src-ag/Order.ag" #-} + if _maptolocal + then [ AltAttr _LOC name_ True ] + else [ AltAttr name_ syn True | syn <- Map.keys _syn ] + {-# LINE 353 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule5 #-} + {-# LINE 198 "src-ag/Order.ag" #-} + rule5 = \ name_ tp_ -> + {-# LINE 198 "src-ag/Order.ag" #-} + Seq.singleton (name_,getNtName tp_) + {-# LINE 359 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule6 #-} + {-# LINE 199 "src-ag/Order.ag" #-} + rule6 = \ _inh name_ -> + {-# LINE 199 "src-ag/Order.ag" #-} + Seq.singleton (name_,_inh ) + {-# LINE 365 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule7 #-} + {-# LINE 215 "src-ag/Order.ag" #-} + rule7 = \ ((_lhsIcon) :: Identifier) ((_lhsInt) :: Identifier) _maptolocal _syn name_ tp_ -> + {-# LINE 215 "src-ag/Order.ag" #-} + if _maptolocal + then Seq.singleton (cRuleTerminal name_ _lhsInt _lhsIcon tp_) + else Seq.fromList [ cRuleRhsSyn syn _lhsInt _lhsIcon tp name_ (getNtName tp_) | (syn,tp) <- Map.assocs _syn ] + {-# LINE 373 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule8 #-} + {-# LINE 347 "src-ag/Order.ag" #-} + rule8 = \ _syn name_ -> + {-# LINE 347 "src-ag/Order.ag" #-} + Map.singleton name_ _syn + {-# LINE 379 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule9 #-} + {-# LINE 348 "src-ag/Order.ag" #-} + rule9 = \ _inh name_ -> + {-# LINE 348 "src-ag/Order.ag" #-} + Map.singleton name_ _inh + {-# LINE 385 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule10 #-} + {-# LINE 618 "src-ag/Order.ag" #-} + rule10 = \ _inh _maptolocal _syn name_ tp_ -> + {-# LINE 618 "src-ag/Order.ag" #-} + if _maptolocal + then [] + else [CChildVisit name_ (getNtName tp_) 0 _inh _syn True] + {-# LINE 393 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule11 #-} + {-# LINE 643 "src-ag/Order.ag" #-} + rule11 = \ _maptolocal name_ -> + {-# LINE 643 "src-ag/Order.ag" #-} + if _maptolocal + then [name_] + else [] + {-# LINE 401 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule12 #-} + {-# LINE 672 "src-ag/Order.ag" #-} + rule12 = \ _inh _syn name_ -> + {-# LINE 672 "src-ag/Order.ag" #-} + [(name_, _inh , _syn )] + {-# LINE 407 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule13 #-} + {-# LINE 676 "src-ag/Order.ag" #-} + rule13 = \ kind_ name_ tp_ -> + {-# LINE 676 "src-ag/Order.ag" #-} + (name_, tp_, kind_) + {-# LINE 413 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule14 #-} + {-# LINE 50 "src-ag/TfmToMirage.ag" #-} + rule14 = \ name_ tp_ -> + {-# LINE 50 "src-ag/TfmToMirage.ag" #-} + Mirage.Child (getName name_) (typeToMirage tp_) + {-# LINE 419 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule15 #-} + rule15 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule16 #-} + rule16 = \ _gathRules -> + _gathRules + +-- Children ---------------------------------------------------- +-- wrapper +data Inh_Children = Inh_Children { allfields_Inh_Children :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Children :: ([Identifier]), attrs_Inh_Children :: ([(Identifier,Identifier)]), con_Inh_Children :: (Identifier), inh_Inh_Children :: (Attributes), inhMap_Inh_Children :: (Map Identifier Attributes), mergeMap_Inh_Children :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Children :: (Identifier), o_unbox_Inh_Children :: (Bool), syn_Inh_Children :: (Attributes), synMap_Inh_Children :: (Map Identifier Attributes) } +data Syn_Children = Syn_Children { attributes_Syn_Children :: ([(Identifier,Attributes,Attributes)]), collectChildrenInhs_Syn_Children :: (Map Identifier Attributes ), collectChildrenSyns_Syn_Children :: (Map Identifier Attributes ), errors_Syn_Children :: (Seq Error), fields_Syn_Children :: ([(Identifier,Type,ChildKind)]), gathAltAttrs_Syn_Children :: ([AltAttr]), gathRules_Syn_Children :: (Seq CRule), inhs_Syn_Children :: (Seq (Identifier,Attributes)), mirages_Syn_Children :: ([Mirage.Child]), nts_Syn_Children :: (Seq (Identifier,NontermIdent)), singlevisits_Syn_Children :: ([CRule]), terminals_Syn_Children :: ([Identifier]) } +{-# INLINABLE wrap_Children #-} +wrap_Children :: T_Children -> Inh_Children -> (Syn_Children ) +wrap_Children (T_Children act) (Inh_Children _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg4 = T_Children_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap + (T_Children_vOut4 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirages _lhsOnts _lhsOsinglevisits _lhsOterminals) <- return (inv_Children_s5 sem arg4) + return (Syn_Children _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirages _lhsOnts _lhsOsinglevisits _lhsOterminals) + ) + +-- cata +{-# NOINLINE sem_Children #-} +sem_Children :: Children -> T_Children +sem_Children list = Prelude.foldr sem_Children_Cons sem_Children_Nil (Prelude.map sem_Child list) + +-- semantic domain +newtype T_Children = T_Children { + attach_T_Children :: Identity (T_Children_s5 ) + } +newtype T_Children_s5 = C_Children_s5 { + inv_Children_s5 :: (T_Children_v4 ) + } +data T_Children_s6 = C_Children_s6 +type T_Children_v4 = (T_Children_vIn4 ) -> (T_Children_vOut4 ) +data T_Children_vIn4 = T_Children_vIn4 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Bool) (Attributes) (Map Identifier Attributes) +data T_Children_vOut4 = T_Children_vOut4 ([(Identifier,Attributes,Attributes)]) (Map Identifier Attributes ) (Map Identifier Attributes ) (Seq Error) ([(Identifier,Type,ChildKind)]) ([AltAttr]) (Seq CRule) (Seq (Identifier,Attributes)) ([Mirage.Child]) (Seq (Identifier,NontermIdent)) ([CRule]) ([Identifier]) +{-# NOINLINE sem_Children_Cons #-} +sem_Children_Cons :: T_Child -> T_Children -> T_Children +sem_Children_Cons arg_hd_ arg_tl_ = T_Children (return st5) where + {-# NOINLINE st5 #-} + st5 = let + v4 :: T_Children_v4 + v4 = \ (T_Children_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) -> ( let + _hdX2 = Control.Monad.Identity.runIdentity (attach_T_Child (arg_hd_)) + _tlX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_tl_)) + (T_Child_vOut1 _hdIattributes _hdIcollectChildrenInhs _hdIcollectChildrenSyns _hdIerrors _hdIfield _hdIgathAltAttrs _hdIgathRules _hdIinhs _hdImirage _hdInts _hdIsinglevisits _hdIterminals) = inv_Child_s2 _hdX2 (T_Child_vIn1 _hdOallfields _hdOallnts _hdOattrs _hdOcon _hdOinh _hdOinhMap _hdOmergeMap _hdOnt _hdOo_unbox _hdOsyn _hdOsynMap) + (T_Children_vOut4 _tlIattributes _tlIcollectChildrenInhs _tlIcollectChildrenSyns _tlIerrors _tlIfields _tlIgathAltAttrs _tlIgathRules _tlIinhs _tlImirages _tlInts _tlIsinglevisits _tlIterminals) = inv_Children_s5 _tlX5 (T_Children_vIn4 _tlOallfields _tlOallnts _tlOattrs _tlOcon _tlOinh _tlOinhMap _tlOmergeMap _tlOnt _tlOo_unbox _tlOsyn _tlOsynMap) + _lhsOfields :: [(Identifier,Type,ChildKind)] + _lhsOfields = rule17 _hdIfield _tlIfields + _lhsOmirages :: [Mirage.Child] + _lhsOmirages = rule18 _hdImirage _tlImirages + _lhsOattributes :: [(Identifier,Attributes,Attributes)] + _lhsOattributes = rule19 _hdIattributes _tlIattributes + _lhsOcollectChildrenInhs :: Map Identifier Attributes + _lhsOcollectChildrenInhs = rule20 _hdIcollectChildrenInhs _tlIcollectChildrenInhs + _lhsOcollectChildrenSyns :: Map Identifier Attributes + _lhsOcollectChildrenSyns = rule21 _hdIcollectChildrenSyns _tlIcollectChildrenSyns + _lhsOerrors :: Seq Error + _lhsOerrors = rule22 _hdIerrors _tlIerrors + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule23 _hdIgathAltAttrs _tlIgathAltAttrs + _lhsOgathRules :: Seq CRule + _lhsOgathRules = rule24 _hdIgathRules _tlIgathRules + _lhsOinhs :: Seq (Identifier,Attributes) + _lhsOinhs = rule25 _hdIinhs _tlIinhs + _lhsOnts :: Seq (Identifier,NontermIdent) + _lhsOnts = rule26 _hdInts _tlInts + _lhsOsinglevisits :: [CRule] + _lhsOsinglevisits = rule27 _hdIsinglevisits _tlIsinglevisits + _lhsOterminals :: [Identifier] + _lhsOterminals = rule28 _hdIterminals _tlIterminals + _hdOallfields = rule29 _lhsIallfields + _hdOallnts = rule30 _lhsIallnts + _hdOattrs = rule31 _lhsIattrs + _hdOcon = rule32 _lhsIcon + _hdOinh = rule33 _lhsIinh + _hdOinhMap = rule34 _lhsIinhMap + _hdOmergeMap = rule35 _lhsImergeMap + _hdOnt = rule36 _lhsInt + _hdOo_unbox = rule37 _lhsIo_unbox + _hdOsyn = rule38 _lhsIsyn + _hdOsynMap = rule39 _lhsIsynMap + _tlOallfields = rule40 _lhsIallfields + _tlOallnts = rule41 _lhsIallnts + _tlOattrs = rule42 _lhsIattrs + _tlOcon = rule43 _lhsIcon + _tlOinh = rule44 _lhsIinh + _tlOinhMap = rule45 _lhsIinhMap + _tlOmergeMap = rule46 _lhsImergeMap + _tlOnt = rule47 _lhsInt + _tlOo_unbox = rule48 _lhsIo_unbox + _tlOsyn = rule49 _lhsIsyn + _tlOsynMap = rule50 _lhsIsynMap + __result_ = T_Children_vOut4 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirages _lhsOnts _lhsOsinglevisits _lhsOterminals + in __result_ ) + in C_Children_s5 v4 + {-# INLINE rule17 #-} + {-# LINE 679 "src-ag/Order.ag" #-} + rule17 = \ ((_hdIfield) :: (Identifier,Type,ChildKind)) ((_tlIfields) :: [(Identifier,Type,ChildKind)]) -> + {-# LINE 679 "src-ag/Order.ag" #-} + _hdIfield : _tlIfields + {-# LINE 522 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule18 #-} + {-# LINE 46 "src-ag/TfmToMirage.ag" #-} + rule18 = \ ((_hdImirage) :: Mirage.Child) ((_tlImirages) :: [Mirage.Child]) -> + {-# LINE 46 "src-ag/TfmToMirage.ag" #-} + _hdImirage : _tlImirages + {-# LINE 528 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule19 #-} + rule19 = \ ((_hdIattributes) :: [(Identifier,Attributes,Attributes)]) ((_tlIattributes) :: [(Identifier,Attributes,Attributes)]) -> + _hdIattributes ++ _tlIattributes + {-# INLINE rule20 #-} + rule20 = \ ((_hdIcollectChildrenInhs) :: Map Identifier Attributes ) ((_tlIcollectChildrenInhs) :: Map Identifier Attributes ) -> + _hdIcollectChildrenInhs `Map.union` _tlIcollectChildrenInhs + {-# INLINE rule21 #-} + rule21 = \ ((_hdIcollectChildrenSyns) :: Map Identifier Attributes ) ((_tlIcollectChildrenSyns) :: Map Identifier Attributes ) -> + _hdIcollectChildrenSyns `Map.union` _tlIcollectChildrenSyns + {-# INLINE rule22 #-} + rule22 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> + _hdIerrors Seq.>< _tlIerrors + {-# INLINE rule23 #-} + rule23 = \ ((_hdIgathAltAttrs) :: [AltAttr]) ((_tlIgathAltAttrs) :: [AltAttr]) -> + _hdIgathAltAttrs ++ _tlIgathAltAttrs + {-# INLINE rule24 #-} + rule24 = \ ((_hdIgathRules) :: Seq CRule) ((_tlIgathRules) :: Seq CRule) -> + _hdIgathRules Seq.>< _tlIgathRules + {-# INLINE rule25 #-} + rule25 = \ ((_hdIinhs) :: Seq (Identifier,Attributes)) ((_tlIinhs) :: Seq (Identifier,Attributes)) -> + _hdIinhs Seq.>< _tlIinhs + {-# INLINE rule26 #-} + rule26 = \ ((_hdInts) :: Seq (Identifier,NontermIdent)) ((_tlInts) :: Seq (Identifier,NontermIdent)) -> + _hdInts Seq.>< _tlInts + {-# INLINE rule27 #-} + rule27 = \ ((_hdIsinglevisits) :: [CRule]) ((_tlIsinglevisits) :: [CRule]) -> + _hdIsinglevisits ++ _tlIsinglevisits + {-# INLINE rule28 #-} + rule28 = \ ((_hdIterminals) :: [Identifier]) ((_tlIterminals) :: [Identifier]) -> + _hdIterminals ++ _tlIterminals + {-# INLINE rule29 #-} + rule29 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> + _lhsIallfields + {-# INLINE rule30 #-} + rule30 = \ ((_lhsIallnts) :: [Identifier]) -> + _lhsIallnts + {-# INLINE rule31 #-} + rule31 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> + _lhsIattrs + {-# INLINE rule32 #-} + rule32 = \ ((_lhsIcon) :: Identifier) -> + _lhsIcon + {-# INLINE rule33 #-} + rule33 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule34 #-} + rule34 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> + _lhsIinhMap + {-# INLINE rule35 #-} + rule35 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> + _lhsImergeMap + {-# INLINE rule36 #-} + rule36 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule37 #-} + rule37 = \ ((_lhsIo_unbox) :: Bool) -> + _lhsIo_unbox + {-# INLINE rule38 #-} + rule38 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn + {-# INLINE rule39 #-} + rule39 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> + _lhsIsynMap + {-# INLINE rule40 #-} + rule40 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> + _lhsIallfields + {-# INLINE rule41 #-} + rule41 = \ ((_lhsIallnts) :: [Identifier]) -> + _lhsIallnts + {-# INLINE rule42 #-} + rule42 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> + _lhsIattrs + {-# INLINE rule43 #-} + rule43 = \ ((_lhsIcon) :: Identifier) -> + _lhsIcon + {-# INLINE rule44 #-} + rule44 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule45 #-} + rule45 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> + _lhsIinhMap + {-# INLINE rule46 #-} + rule46 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> + _lhsImergeMap + {-# INLINE rule47 #-} + rule47 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule48 #-} + rule48 = \ ((_lhsIo_unbox) :: Bool) -> + _lhsIo_unbox + {-# INLINE rule49 #-} + rule49 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn + {-# INLINE rule50 #-} + rule50 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> + _lhsIsynMap +{-# NOINLINE sem_Children_Nil #-} +sem_Children_Nil :: T_Children +sem_Children_Nil = T_Children (return st5) where + {-# NOINLINE st5 #-} + st5 = let + v4 :: T_Children_v4 + v4 = \ (T_Children_vIn4 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsIinh _lhsIinhMap _lhsImergeMap _lhsInt _lhsIo_unbox _lhsIsyn _lhsIsynMap) -> ( let + _lhsOfields :: [(Identifier,Type,ChildKind)] + _lhsOfields = rule51 () + _lhsOmirages :: [Mirage.Child] + _lhsOmirages = rule52 () + _lhsOattributes :: [(Identifier,Attributes,Attributes)] + _lhsOattributes = rule53 () + _lhsOcollectChildrenInhs :: Map Identifier Attributes + _lhsOcollectChildrenInhs = rule54 () + _lhsOcollectChildrenSyns :: Map Identifier Attributes + _lhsOcollectChildrenSyns = rule55 () + _lhsOerrors :: Seq Error + _lhsOerrors = rule56 () + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule57 () + _lhsOgathRules :: Seq CRule + _lhsOgathRules = rule58 () + _lhsOinhs :: Seq (Identifier,Attributes) + _lhsOinhs = rule59 () + _lhsOnts :: Seq (Identifier,NontermIdent) + _lhsOnts = rule60 () + _lhsOsinglevisits :: [CRule] + _lhsOsinglevisits = rule61 () + _lhsOterminals :: [Identifier] + _lhsOterminals = rule62 () + __result_ = T_Children_vOut4 _lhsOattributes _lhsOcollectChildrenInhs _lhsOcollectChildrenSyns _lhsOerrors _lhsOfields _lhsOgathAltAttrs _lhsOgathRules _lhsOinhs _lhsOmirages _lhsOnts _lhsOsinglevisits _lhsOterminals + in __result_ ) + in C_Children_s5 v4 + {-# INLINE rule51 #-} + {-# LINE 680 "src-ag/Order.ag" #-} + rule51 = \ (_ :: ()) -> + {-# LINE 680 "src-ag/Order.ag" #-} + [] + {-# LINE 664 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule52 #-} + {-# LINE 47 "src-ag/TfmToMirage.ag" #-} + rule52 = \ (_ :: ()) -> + {-# LINE 47 "src-ag/TfmToMirage.ag" #-} + [] + {-# LINE 670 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule53 #-} + rule53 = \ (_ :: ()) -> + [] + {-# INLINE rule54 #-} + rule54 = \ (_ :: ()) -> + Map.empty + {-# INLINE rule55 #-} + rule55 = \ (_ :: ()) -> + Map.empty + {-# INLINE rule56 #-} + rule56 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule57 #-} + rule57 = \ (_ :: ()) -> + [] + {-# INLINE rule58 #-} + rule58 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule59 #-} + rule59 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule60 #-} + rule60 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule61 #-} + rule61 = \ (_ :: ()) -> + [] + {-# INLINE rule62 #-} + rule62 = \ (_ :: ()) -> + [] + +-- Expression -------------------------------------------------- +-- wrapper +data Inh_Expression = Inh_Expression { allfields_Inh_Expression :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Expression :: ([Identifier]), attrs_Inh_Expression :: ([(Identifier,Identifier)]), con_Inh_Expression :: (Identifier), mergeMap_Inh_Expression :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Expression :: (Identifier), options_Inh_Expression :: (Options) } +data Syn_Expression = Syn_Expression { allRhsVars_Syn_Expression :: (Set (Identifier,Identifier)), copy_Syn_Expression :: (Expression), errors_Syn_Expression :: (Seq Error), lns_Syn_Expression :: ([String]), textLines_Syn_Expression :: ([String]), usedAttrs_Syn_Expression :: ([(Identifier,Identifier)]), usedFields_Syn_Expression :: ([Identifier]), usedLocals_Syn_Expression :: ([Identifier]) } +{-# INLINABLE wrap_Expression #-} +wrap_Expression :: T_Expression -> Inh_Expression -> (Syn_Expression ) +wrap_Expression (T_Expression act) (Inh_Expression _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt _lhsIoptions) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg7 = T_Expression_vIn7 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt _lhsIoptions + (T_Expression_vOut7 _lhsOallRhsVars _lhsOcopy _lhsOerrors _lhsOlns _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals) <- return (inv_Expression_s8 sem arg7) + return (Syn_Expression _lhsOallRhsVars _lhsOcopy _lhsOerrors _lhsOlns _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals) + ) + +-- cata +{-# INLINE sem_Expression #-} +sem_Expression :: Expression -> T_Expression +sem_Expression ( Expression pos_ tks_ ) = sem_Expression_Expression pos_ tks_ + +-- semantic domain +newtype T_Expression = T_Expression { + attach_T_Expression :: Identity (T_Expression_s8 ) + } +newtype T_Expression_s8 = C_Expression_s8 { + inv_Expression_s8 :: (T_Expression_v7 ) + } +data T_Expression_s9 = C_Expression_s9 +type T_Expression_v7 = (T_Expression_vIn7 ) -> (T_Expression_vOut7 ) +data T_Expression_vIn7 = T_Expression_vIn7 ([(Identifier,Type,ChildKind)]) ([Identifier]) ([(Identifier,Identifier)]) (Identifier) (Map Identifier (Identifier,[Identifier])) (Identifier) (Options) +data T_Expression_vOut7 = T_Expression_vOut7 (Set (Identifier,Identifier)) (Expression) (Seq Error) ([String]) ([String]) ([(Identifier,Identifier)]) ([Identifier]) ([Identifier]) +{-# NOINLINE sem_Expression_Expression #-} +sem_Expression_Expression :: (Pos) -> ([HsToken]) -> T_Expression +sem_Expression_Expression arg_pos_ arg_tks_ = T_Expression (return st8) where + {-# NOINLINE st8 #-} + st8 = let + v7 :: T_Expression_v7 + v7 = \ (T_Expression_vIn7 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt _lhsIoptions) -> ( let + (_textLines,_usedAttrs,_usedLocals,_usedFields) = rule63 _lhsIallfields _lhsIallnts _lhsIattrs _lhsIcon _lhsImergeMap _lhsInt _lhsIoptions arg_tks_ + _lhsOerrors :: Seq Error + _lhsOerrors = rule64 () + _lhsOallRhsVars :: Set (Identifier,Identifier) + _lhsOallRhsVars = rule65 _usedAttrs _usedFields _usedLocals + _lhsOlns :: [String] + _lhsOlns = rule66 arg_tks_ + _copy = rule67 arg_pos_ arg_tks_ + _lhsOcopy :: Expression + _lhsOcopy = rule68 _copy + _lhsOtextLines :: [String] + _lhsOtextLines = rule69 _textLines + _lhsOusedAttrs :: [(Identifier,Identifier)] + _lhsOusedAttrs = rule70 _usedAttrs + _lhsOusedFields :: [Identifier] + _lhsOusedFields = rule71 _usedFields + _lhsOusedLocals :: [Identifier] + _lhsOusedLocals = rule72 _usedLocals + __result_ = T_Expression_vOut7 _lhsOallRhsVars _lhsOcopy _lhsOerrors _lhsOlns _lhsOtextLines _lhsOusedAttrs _lhsOusedFields _lhsOusedLocals + in __result_ ) + in C_Expression_s8 v7 + {-# INLINE rule63 #-} + {-# LINE 469 "src-ag/Order.ag" #-} + rule63 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) ((_lhsIallnts) :: [Identifier]) ((_lhsIattrs) :: [(Identifier,Identifier)]) ((_lhsIcon) :: Identifier) ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) ((_lhsInt) :: Identifier) ((_lhsIoptions) :: Options) tks_ -> + {-# LINE 469 "src-ag/Order.ag" #-} + let mergedChildren = [ x | (_,xs) <- Map.elems _lhsImergeMap, x <- xs ] + attrsIn = filter (\(fld,_) -> not (fld `elem` mergedChildren)) _lhsIattrs + inherited = Inh_HsTokensRoot + { attrs_Inh_HsTokensRoot = attrsIn + , con_Inh_HsTokensRoot = _lhsIcon + , allfields_Inh_HsTokensRoot = _lhsIallfields + , allnts_Inh_HsTokensRoot = _lhsIallnts + , nt_Inh_HsTokensRoot = _lhsInt + , options_Inh_HsTokensRoot = _lhsIoptions + } + synthesized = wrap_HsTokensRoot (sem_HsTokensRoot (HsTokensRoot tks_)) inherited + in case synthesized of + Syn_HsTokensRoot + { textLines_Syn_HsTokensRoot = textLines + , usedAttrs_Syn_HsTokensRoot = usedAttrs + , usedLocals_Syn_HsTokensRoot = usedLocals + , usedFields_Syn_HsTokensRoot = usedFields + } -> let extraAttrs = [ (src,attr) + | (fld,attr) <- usedAttrs, let mbMerged = Map.lookup fld _lhsImergeMap, isJust mbMerged + , let (Just (_, srcs)) = mbMerged, src <- srcs ] + usedAttrs' = usedAttrs ++ extraAttrs + in (textLines,usedAttrs',usedLocals,usedFields) + {-# LINE 786 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule64 #-} + {-# LINE 492 "src-ag/Order.ag" #-} + rule64 = \ (_ :: ()) -> + {-# LINE 492 "src-ag/Order.ag" #-} + Seq.empty + {-# LINE 792 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule65 #-} + {-# LINE 493 "src-ag/Order.ag" #-} + rule65 = \ _usedAttrs _usedFields _usedLocals -> + {-# LINE 493 "src-ag/Order.ag" #-} + Set.fromList _usedAttrs + `Set.union` + Set.fromList [ (_LOC, l) | l <- _usedLocals ] + `Set.union` + Set.fromList [ (_FIELD, fld) | fld <- _usedFields ] + {-# LINE 802 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule66 #-} + {-# LINE 71 "src-ag/TfmToMirage.ag" #-} + rule66 = \ tks_ -> + {-# LINE 71 "src-ag/TfmToMirage.ag" #-} + showTokens . tokensToStrings $ tks_ + {-# LINE 808 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule67 #-} + rule67 = \ pos_ tks_ -> + Expression pos_ tks_ + {-# INLINE rule68 #-} + rule68 = \ _copy -> + _copy + {-# INLINE rule69 #-} + rule69 = \ _textLines -> + _textLines + {-# INLINE rule70 #-} + rule70 = \ _usedAttrs -> + _usedAttrs + {-# INLINE rule71 #-} + rule71 = \ _usedFields -> + _usedFields + {-# INLINE rule72 #-} + rule72 = \ _usedLocals -> + _usedLocals + +-- Grammar ----------------------------------------------------- +-- wrapper +data Inh_Grammar = Inh_Grammar { options_Inh_Grammar :: (Options) } +data Syn_Grammar = Syn_Grammar { errors_Syn_Grammar :: (Seq Error), mirage_Syn_Grammar :: (Mirage.Grammar), nAutoRules_Syn_Grammar :: (Int), nExplicitRules_Syn_Grammar :: (Int), output_Syn_Grammar :: (CGrammar) } +{-# INLINABLE wrap_Grammar #-} +wrap_Grammar :: T_Grammar -> Inh_Grammar -> (Syn_Grammar ) +wrap_Grammar (T_Grammar act) (Inh_Grammar _lhsIoptions) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg10 = T_Grammar_vIn10 _lhsIoptions + (T_Grammar_vOut10 _lhsOerrors _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOoutput) <- return (inv_Grammar_s11 sem arg10) + return (Syn_Grammar _lhsOerrors _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOoutput) + ) + +-- cata +{-# INLINE sem_Grammar #-} +sem_Grammar :: Grammar -> T_Grammar +sem_Grammar ( Grammar typeSyns_ useMap_ derivings_ wrappers_ nonts_ pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ ) = sem_Grammar_Grammar typeSyns_ useMap_ derivings_ wrappers_ ( sem_Nonterminals nonts_ ) pragmas_ manualAttrOrderMap_ paramMap_ contextMap_ quantMap_ uniqueMap_ augmentsMap_ aroundsMap_ mergeMap_ + +-- semantic domain +newtype T_Grammar = T_Grammar { + attach_T_Grammar :: Identity (T_Grammar_s11 ) + } +newtype T_Grammar_s11 = C_Grammar_s11 { + inv_Grammar_s11 :: (T_Grammar_v10 ) + } +data T_Grammar_s12 = C_Grammar_s12 +type T_Grammar_v10 = (T_Grammar_vIn10 ) -> (T_Grammar_vOut10 ) +data T_Grammar_vIn10 = T_Grammar_vIn10 (Options) +data T_Grammar_vOut10 = T_Grammar_vOut10 (Seq Error) (Mirage.Grammar) (Int) (Int) (CGrammar) +{-# NOINLINE sem_Grammar_Grammar #-} +sem_Grammar_Grammar :: (TypeSyns) -> (UseMap) -> (Derivings) -> (Set NontermIdent) -> T_Nonterminals -> (PragmaMap) -> (AttrOrderMap) -> (ParamMap) -> (ContextMap) -> (QuantMap) -> (UniqueMap) -> (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression)))) -> T_Grammar +sem_Grammar_Grammar arg_typeSyns_ _ arg_derivings_ arg_wrappers_ arg_nonts_ arg_pragmas_ arg_manualAttrOrderMap_ arg_paramMap_ arg_contextMap_ arg_quantMap_ _ _ arg_aroundsMap_ arg_mergeMap_ = T_Grammar (return st11) where + {-# NOINLINE st11 #-} + st11 = let + v10 :: T_Grammar_v10 + v10 = \ (T_Grammar_vIn10 _lhsIoptions) -> ( let + _nontsX17 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_nonts_)) + (T_Nonterminals_vOut16 _nontsIacount _nontsIadditionalDep _nontsIaranges _nontsIaroundDep _nontsIcNonterminals _nontsIdirectDep _nontsIerrors _nontsIinhMap' _nontsIinstDep _nontsImergeDep _nontsImirages _nontsInAutoRules _nontsInExplicitRules _nontsInonts _nontsIntattrs _nontsIrules _nontsIsynMap' _nontsIvcount) = inv_Nonterminals_s17 _nontsX17 (T_Nonterminals_vIn16 _nontsOacount _nontsOallnts _nontsOaroundMap _nontsOcInterfaceMap _nontsOcVisitsMap _nontsOinhMap _nontsOmanualAttrDepMap _nontsOmergeMap _nontsOo_case _nontsOo_cata _nontsOo_data _nontsOo_dovisit _nontsOo_newtypes _nontsOo_rename _nontsOo_sem _nontsOo_sig _nontsOo_unbox _nontsOo_wantvisit _nontsOoptions _nontsOprefix _nontsOsynMap _nontsOvcount) + _nontsOinhMap = rule73 _nontsIinhMap' + _nontsOsynMap = rule74 _nontsIsynMap' + _o_dovisit = rule75 _cyclesErrors _lhsIoptions + _nontsOo_cata = rule76 _lhsIoptions + _nontsOo_data = rule77 _lhsIoptions + _nontsOo_sig = rule78 _lhsIoptions + _nontsOo_sem = rule79 _lhsIoptions + _nontsOo_rename = rule80 _lhsIoptions + _nontsOo_newtypes = rule81 _lhsIoptions + _nontsOo_wantvisit = rule82 _lhsIoptions + _nontsOo_unbox = rule83 _lhsIoptions + _nontsOo_case = rule84 _lhsIoptions + _nontsOprefix = rule85 _lhsIoptions + _nontsOvcount = rule86 () + _nontsOmanualAttrDepMap = rule87 arg_manualAttrOrderMap_ + _nontsOaroundMap = rule88 arg_aroundsMap_ + _nontsOacount = rule89 () + _ruleTable = rule90 _nontsIrules _nontsIvcount + _attrTable = rule91 _nontsIacount _nontsIntattrs + _attrVertex = rule92 _nontsIntattrs + _tdpToTds = rule93 _attrVertex _nontsIrules + _tdsToTdp = rule94 _tdpToTds + _directDep = rule95 _nontsIadditionalDep _nontsIdirectDep + _instDep = rule96 _nontsIinstDep + _aroundDep = rule97 _nontsIaroundDep + _mergeDep = rule98 _nontsImergeDep + _info = rule99 _attrTable _nontsIacount _nontsIaranges _nontsInonts _nontsIvcount _ruleTable _tdpToTds _tdsToTdp arg_wrappers_ + (_cInterfaceMap,_cVisitsMap,_cyclesErrors) = rule100 _aroundDep _attrTable _directDep _info _instDep _lhsIoptions _mergeDep _ruleTable + _lhsOerrors :: Seq Error + _lhsOerrors = rule101 _cyclesErrors _lhsIoptions _nontsIerrors + _lhsOoutput :: CGrammar + _lhsOoutput = rule102 _aroundMap _mergeMap _nontsIcNonterminals _o_dovisit arg_contextMap_ arg_derivings_ arg_paramMap_ arg_pragmas_ arg_quantMap_ arg_typeSyns_ arg_wrappers_ + _aroundMap = rule103 arg_aroundsMap_ + _mergeMap = rule104 arg_mergeMap_ + _nontsOallnts = rule105 _nontsInonts + _lhsOmirage :: Mirage.Grammar + _lhsOmirage = rule106 _nontsImirages + _lhsOnAutoRules :: Int + _lhsOnAutoRules = rule107 _nontsInAutoRules + _lhsOnExplicitRules :: Int + _lhsOnExplicitRules = rule108 _nontsInExplicitRules + _nontsOcInterfaceMap = rule109 _cInterfaceMap + _nontsOcVisitsMap = rule110 _cVisitsMap + _nontsOmergeMap = rule111 _mergeMap + _nontsOo_dovisit = rule112 _o_dovisit + _nontsOoptions = rule113 _lhsIoptions + __result_ = T_Grammar_vOut10 _lhsOerrors _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOoutput + in __result_ ) + in C_Grammar_s11 v10 + {-# INLINE rule73 #-} + {-# LINE 15 "src-ag/DistChildAttr.ag" #-} + rule73 = \ ((_nontsIinhMap') :: Map Identifier Attributes) -> + {-# LINE 15 "src-ag/DistChildAttr.ag" #-} + _nontsIinhMap' + {-# LINE 921 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule74 #-} + {-# LINE 16 "src-ag/DistChildAttr.ag" #-} + rule74 = \ ((_nontsIsynMap') :: Map Identifier Attributes) -> + {-# LINE 16 "src-ag/DistChildAttr.ag" #-} + _nontsIsynMap' + {-# LINE 927 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule75 #-} + {-# LINE 123 "src-ag/Order.ag" #-} + rule75 = \ _cyclesErrors ((_lhsIoptions) :: Options) -> + {-# LINE 123 "src-ag/Order.ag" #-} + visit _lhsIoptions && null _cyclesErrors + {-# LINE 933 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule76 #-} + {-# LINE 124 "src-ag/Order.ag" #-} + rule76 = \ ((_lhsIoptions) :: Options) -> + {-# LINE 124 "src-ag/Order.ag" #-} + folds _lhsIoptions + {-# LINE 939 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule77 #-} + {-# LINE 125 "src-ag/Order.ag" #-} + rule77 = \ ((_lhsIoptions) :: Options) -> + {-# LINE 125 "src-ag/Order.ag" #-} + dataTypes _lhsIoptions + {-# LINE 945 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule78 #-} + {-# LINE 126 "src-ag/Order.ag" #-} + rule78 = \ ((_lhsIoptions) :: Options) -> + {-# LINE 126 "src-ag/Order.ag" #-} + typeSigs _lhsIoptions + {-# LINE 951 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule79 #-} + {-# LINE 127 "src-ag/Order.ag" #-} + rule79 = \ ((_lhsIoptions) :: Options) -> + {-# LINE 127 "src-ag/Order.ag" #-} + semfuns _lhsIoptions + {-# LINE 957 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule80 #-} + {-# LINE 128 "src-ag/Order.ag" #-} + rule80 = \ ((_lhsIoptions) :: Options) -> + {-# LINE 128 "src-ag/Order.ag" #-} + rename _lhsIoptions + {-# LINE 963 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule81 #-} + {-# LINE 129 "src-ag/Order.ag" #-} + rule81 = \ ((_lhsIoptions) :: Options) -> + {-# LINE 129 "src-ag/Order.ag" #-} + newtypes _lhsIoptions + {-# LINE 969 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule82 #-} + {-# LINE 130 "src-ag/Order.ag" #-} + rule82 = \ ((_lhsIoptions) :: Options) -> + {-# LINE 130 "src-ag/Order.ag" #-} + visit _lhsIoptions + {-# LINE 975 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule83 #-} + {-# LINE 131 "src-ag/Order.ag" #-} + rule83 = \ ((_lhsIoptions) :: Options) -> + {-# LINE 131 "src-ag/Order.ag" #-} + unbox _lhsIoptions + {-# LINE 981 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule84 #-} + {-# LINE 132 "src-ag/Order.ag" #-} + rule84 = \ ((_lhsIoptions) :: Options) -> + {-# LINE 132 "src-ag/Order.ag" #-} + cases _lhsIoptions + {-# LINE 987 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule85 #-} + {-# LINE 133 "src-ag/Order.ag" #-} + rule85 = \ ((_lhsIoptions) :: Options) -> + {-# LINE 133 "src-ag/Order.ag" #-} + prefix _lhsIoptions + {-# LINE 993 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule86 #-} + {-# LINE 262 "src-ag/Order.ag" #-} + rule86 = \ (_ :: ()) -> + {-# LINE 262 "src-ag/Order.ag" #-} + 0 + {-# LINE 999 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule87 #-} + {-# LINE 288 "src-ag/Order.ag" #-} + rule87 = \ manualAttrOrderMap_ -> + {-# LINE 288 "src-ag/Order.ag" #-} + manualAttrOrderMap_ + {-# LINE 1005 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule88 #-} + {-# LINE 417 "src-ag/Order.ag" #-} + rule88 = \ aroundsMap_ -> + {-# LINE 417 "src-ag/Order.ag" #-} + aroundsMap_ + {-# LINE 1011 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule89 #-} + {-# LINE 508 "src-ag/Order.ag" #-} + rule89 = \ (_ :: ()) -> + {-# LINE 508 "src-ag/Order.ag" #-} + 0 + {-# LINE 1017 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule90 #-} + {-# LINE 546 "src-ag/Order.ag" #-} + rule90 = \ ((_nontsIrules) :: Seq (Vertex,CRule)) ((_nontsIvcount) :: Int) -> + {-# LINE 546 "src-ag/Order.ag" #-} + Array.array (0,_nontsIvcount-1) (toList _nontsIrules) + {-# LINE 1023 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule91 #-} + {-# LINE 547 "src-ag/Order.ag" #-} + rule91 = \ ((_nontsIacount) :: Int) ((_nontsIntattrs) :: Seq (Vertex,NTAttr)) -> + {-# LINE 547 "src-ag/Order.ag" #-} + Array.array (0,_nontsIacount-1) (toList _nontsIntattrs) + {-# LINE 1029 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule92 #-} + {-# LINE 548 "src-ag/Order.ag" #-} + rule92 = \ ((_nontsIntattrs) :: Seq (Vertex,NTAttr)) -> + {-# LINE 548 "src-ag/Order.ag" #-} + Map.fromList (map swap (toList _nontsIntattrs)) + {-# LINE 1035 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule93 #-} + {-# LINE 549 "src-ag/Order.ag" #-} + rule93 = \ _attrVertex ((_nontsIrules) :: Seq (Vertex,CRule)) -> + {-# LINE 549 "src-ag/Order.ag" #-} + [ (s, maybe (-1) (\v -> findWithErr1 "Grammar.tdpToTds" v _attrVertex) (ntattr cr)) + | (s,cr) <- toList _nontsIrules] + {-# LINE 1042 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule94 #-} + {-# LINE 551 "src-ag/Order.ag" #-} + rule94 = \ _tdpToTds -> + {-# LINE 551 "src-ag/Order.ag" #-} + let eq (_,v) (_,v') = v == v' + conv ((s,v):svs) | v == -1 = Nothing + | otherwise = Just (v,s:map fst svs) + in mapMaybe conv (eqClasses eq _tdpToTds) + {-# LINE 1051 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule95 #-} + {-# LINE 555 "src-ag/Order.ag" #-} + rule95 = \ ((_nontsIadditionalDep) :: Seq Edge) ((_nontsIdirectDep) :: Seq Edge) -> + {-# LINE 555 "src-ag/Order.ag" #-} + toList (_nontsIdirectDep Seq.>< _nontsIadditionalDep) + {-# LINE 1057 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule96 #-} + {-# LINE 556 "src-ag/Order.ag" #-} + rule96 = \ ((_nontsIinstDep) :: Seq Edge) -> + {-# LINE 556 "src-ag/Order.ag" #-} + toList _nontsIinstDep + {-# LINE 1063 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule97 #-} + {-# LINE 557 "src-ag/Order.ag" #-} + rule97 = \ ((_nontsIaroundDep) :: Seq Edge) -> + {-# LINE 557 "src-ag/Order.ag" #-} + toList _nontsIaroundDep + {-# LINE 1069 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule98 #-} + {-# LINE 558 "src-ag/Order.ag" #-} + rule98 = \ ((_nontsImergeDep) :: Seq Edge) -> + {-# LINE 558 "src-ag/Order.ag" #-} + toList _nontsImergeDep + {-# LINE 1075 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule99 #-} + {-# LINE 559 "src-ag/Order.ag" #-} + rule99 = \ _attrTable ((_nontsIacount) :: Int) ((_nontsIaranges) :: Seq (Int,Int,Int)) ((_nontsInonts) :: [(NontermIdent,[ConstructorIdent])]) ((_nontsIvcount) :: Int) _ruleTable _tdpToTds _tdsToTdp wrappers_ -> + {-# LINE 559 "src-ag/Order.ag" #-} + let def [] = -1 + def (v:vs) = v + in Info { tdsToTdp = Array.array (0,_nontsIacount-1) _tdsToTdp + , tdpToTds = Array.array (0,_nontsIvcount-1) _tdpToTds + , attrTable = _attrTable + , ruleTable = _ruleTable + , lmh = toList _nontsIaranges + , nonts = _nontsInonts + , wraps = wrappers_ + } + {-# LINE 1090 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule100 #-} + {-# LINE 571 "src-ag/Order.ag" #-} + rule100 = \ _aroundDep _attrTable _directDep _info _instDep ((_lhsIoptions) :: Options) _mergeDep _ruleTable -> + {-# LINE 571 "src-ag/Order.ag" #-} + case computeSequential _info _directDep (_instDep ++ _aroundDep ++ _mergeDep ) of + CycleFree cim cvm -> ( cim + , cvm + , [] + ) + LocalCycle errs -> ( error "No interfaces for AG with local cycles" + , error "No visit sub-sequences for AG with local cycles" + , map (localCycleErr _ruleTable (visit _lhsIoptions)) errs + ) + InstCycle errs -> ( error "No interfaces for AG with cycles through insts" + , error "No visit sub-sequences for AG with cycles through insts" + , map (instCycleErr _ruleTable (visit _lhsIoptions)) errs + ) + DirectCycle errs -> ( error "No interfaces for AG with direct cycles" + , error "No visit sub-sequences for AG with direct cycles" + , directCycleErrs _attrTable _ruleTable (visit _lhsIoptions) errs + ) + InducedCycle cim errs -> ( cim + , error "No visit sub-sequences for AG with induced cycles" + , inducedCycleErrs _attrTable _ruleTable cim errs + ) + {-# LINE 1116 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule101 #-} + {-# LINE 592 "src-ag/Order.ag" #-} + rule101 = \ _cyclesErrors ((_lhsIoptions) :: Options) ((_nontsIerrors) :: Seq Error) -> + {-# LINE 592 "src-ag/Order.ag" #-} + (if withCycle _lhsIoptions then Seq.fromList _cyclesErrors else Seq.empty) + Seq.>< _nontsIerrors + {-# LINE 1123 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule102 #-} + {-# LINE 624 "src-ag/Order.ag" #-} + rule102 = \ _aroundMap _mergeMap ((_nontsIcNonterminals) :: CNonterminals) _o_dovisit contextMap_ derivings_ paramMap_ pragmas_ quantMap_ typeSyns_ wrappers_ -> + {-# LINE 624 "src-ag/Order.ag" #-} + CGrammar typeSyns_ derivings_ wrappers_ _nontsIcNonterminals pragmas_ paramMap_ contextMap_ quantMap_ _aroundMap _mergeMap _o_dovisit + {-# LINE 1129 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule103 #-} + {-# LINE 637 "src-ag/Order.ag" #-} + rule103 = \ aroundsMap_ -> + {-# LINE 637 "src-ag/Order.ag" #-} + Map.map (Map.map Map.keysSet) aroundsMap_ + {-# LINE 1135 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule104 #-} + {-# LINE 638 "src-ag/Order.ag" #-} + rule104 = \ mergeMap_ -> + {-# LINE 638 "src-ag/Order.ag" #-} + Map.map (Map.map (Map.map (\(nt,srcs,_) -> (nt,srcs)))) mergeMap_ + {-# LINE 1141 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule105 #-} + {-# LINE 655 "src-ag/Order.ag" #-} + rule105 = \ ((_nontsInonts) :: [(NontermIdent,[ConstructorIdent])]) -> + {-# LINE 655 "src-ag/Order.ag" #-} + map fst (_nontsInonts) + {-# LINE 1147 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule106 #-} + {-# LINE 22 "src-ag/TfmToMirage.ag" #-} + rule106 = \ ((_nontsImirages) :: [Mirage.Nonterminal]) -> + {-# LINE 22 "src-ag/TfmToMirage.ag" #-} + Mirage.Grammar _nontsImirages + {-# LINE 1153 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule107 #-} + rule107 = \ ((_nontsInAutoRules) :: Int) -> + _nontsInAutoRules + {-# INLINE rule108 #-} + rule108 = \ ((_nontsInExplicitRules) :: Int) -> + _nontsInExplicitRules + {-# INLINE rule109 #-} + rule109 = \ _cInterfaceMap -> + _cInterfaceMap + {-# INLINE rule110 #-} + rule110 = \ _cVisitsMap -> + _cVisitsMap + {-# INLINE rule111 #-} + rule111 = \ _mergeMap -> + _mergeMap + {-# INLINE rule112 #-} + rule112 = \ _o_dovisit -> + _o_dovisit + {-# INLINE rule113 #-} + rule113 = \ ((_lhsIoptions) :: Options) -> + _lhsIoptions + +-- Nonterminal ------------------------------------------------- +-- wrapper +data Inh_Nonterminal = Inh_Nonterminal { acount_Inh_Nonterminal :: (Int), allnts_Inh_Nonterminal :: ([Identifier]), aroundMap_Inh_Nonterminal :: (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), cInterfaceMap_Inh_Nonterminal :: (CInterfaceMap), cVisitsMap_Inh_Nonterminal :: (CVisitsMap), inhMap_Inh_Nonterminal :: (Map Identifier Attributes), manualAttrDepMap_Inh_Nonterminal :: (AttrOrderMap), mergeMap_Inh_Nonterminal :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))), o_case_Inh_Nonterminal :: (Bool), o_cata_Inh_Nonterminal :: (Bool), o_data_Inh_Nonterminal :: (Bool), o_dovisit_Inh_Nonterminal :: (Bool), o_newtypes_Inh_Nonterminal :: (Bool), o_rename_Inh_Nonterminal :: (Bool), o_sem_Inh_Nonterminal :: (Bool), o_sig_Inh_Nonterminal :: (Bool), o_unbox_Inh_Nonterminal :: (Bool), o_wantvisit_Inh_Nonterminal :: (Bool), options_Inh_Nonterminal :: (Options), prefix_Inh_Nonterminal :: (String), synMap_Inh_Nonterminal :: (Map Identifier Attributes), vcount_Inh_Nonterminal :: (Int) } +data Syn_Nonterminal = Syn_Nonterminal { acount_Syn_Nonterminal :: (Int), additionalDep_Syn_Nonterminal :: (Seq Edge), aranges_Syn_Nonterminal :: (Seq (Int,Int,Int)), aroundDep_Syn_Nonterminal :: (Seq Edge), cNonterminal_Syn_Nonterminal :: (CNonterminal), directDep_Syn_Nonterminal :: (Seq Edge), errors_Syn_Nonterminal :: (Seq Error), inhMap'_Syn_Nonterminal :: (Map Identifier Attributes), instDep_Syn_Nonterminal :: (Seq Edge), mergeDep_Syn_Nonterminal :: (Seq Edge), mirage_Syn_Nonterminal :: (Mirage.Nonterminal), nAutoRules_Syn_Nonterminal :: (Int), nExplicitRules_Syn_Nonterminal :: (Int), nonts_Syn_Nonterminal :: ([(NontermIdent,[ConstructorIdent])]), ntattrs_Syn_Nonterminal :: (Seq (Vertex,NTAttr)), rules_Syn_Nonterminal :: (Seq (Vertex,CRule)), synMap'_Syn_Nonterminal :: (Map Identifier Attributes), vcount_Syn_Nonterminal :: (Int) } +{-# INLINABLE wrap_Nonterminal #-} +wrap_Nonterminal :: T_Nonterminal -> Inh_Nonterminal -> (Syn_Nonterminal ) +wrap_Nonterminal (T_Nonterminal act) (Inh_Nonterminal _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg13 = T_Nonterminal_vIn13 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount + (T_Nonterminal_vOut13 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminal _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount) <- return (inv_Nonterminal_s14 sem arg13) + return (Syn_Nonterminal _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminal _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount) + ) + +-- cata +{-# INLINE sem_Nonterminal #-} +sem_Nonterminal :: Nonterminal -> T_Nonterminal +sem_Nonterminal ( Nonterminal nt_ params_ inh_ syn_ prods_ ) = sem_Nonterminal_Nonterminal nt_ params_ inh_ syn_ ( sem_Productions prods_ ) + +-- semantic domain +newtype T_Nonterminal = T_Nonterminal { + attach_T_Nonterminal :: Identity (T_Nonterminal_s14 ) + } +newtype T_Nonterminal_s14 = C_Nonterminal_s14 { + inv_Nonterminal_s14 :: (T_Nonterminal_v13 ) + } +data T_Nonterminal_s15 = C_Nonterminal_s15 +type T_Nonterminal_v13 = (T_Nonterminal_vIn13 ) -> (T_Nonterminal_vOut13 ) +data T_Nonterminal_vIn13 = T_Nonterminal_vIn13 (Int) ([Identifier]) (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) (CInterfaceMap) (CVisitsMap) (Map Identifier Attributes) (AttrOrderMap) (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (String) (Map Identifier Attributes) (Int) +data T_Nonterminal_vOut13 = T_Nonterminal_vOut13 (Int) (Seq Edge) (Seq (Int,Int,Int)) (Seq Edge) (CNonterminal) (Seq Edge) (Seq Error) (Map Identifier Attributes) (Seq Edge) (Seq Edge) (Mirage.Nonterminal) (Int) (Int) ([(NontermIdent,[ConstructorIdent])]) (Seq (Vertex,NTAttr)) (Seq (Vertex,CRule)) (Map Identifier Attributes) (Int) +{-# NOINLINE sem_Nonterminal_Nonterminal #-} +sem_Nonterminal_Nonterminal :: (NontermIdent) -> ([Identifier]) -> (Attributes) -> (Attributes) -> T_Productions -> T_Nonterminal +sem_Nonterminal_Nonterminal arg_nt_ arg_params_ arg_inh_ arg_syn_ arg_prods_ = T_Nonterminal (return st14) where + {-# NOINLINE st14 #-} + st14 = let + v13 :: T_Nonterminal_v13 + v13 = \ (T_Nonterminal_vIn13 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount) -> ( let + _prodsX29 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_prods_)) + (T_Productions_vOut28 _prodsIadditionalDep _prodsIaroundDep _prodsIcProductions _prodsIcons _prodsIdirectDep _prodsIerrors _prodsIinstDep _prodsImergeDep _prodsImirages _prodsInAutoRules _prodsInExplicitRules _prodsIrules _prodsIvcount) = inv_Productions_s29 _prodsX29 (T_Productions_vIn28 _prodsOallnts _prodsOaroundMap _prodsOcVisitsMap _prodsOinh _prodsOinhMap _prodsOmanualAttrDepMap _prodsOmergeMap _prodsOnt _prodsOo_case _prodsOo_cata _prodsOo_dovisit _prodsOo_newtypes _prodsOo_rename _prodsOo_sem _prodsOo_sig _prodsOo_unbox _prodsOo_wantvisit _prodsOoptions _prodsOprefix _prodsOsyn _prodsOsynMap _prodsOvcount) + _lhsOinhMap' :: Map Identifier Attributes + _lhsOinhMap' = rule114 arg_inh_ arg_nt_ + _lhsOsynMap' :: Map Identifier Attributes + _lhsOsynMap' = rule115 arg_nt_ arg_syn_ + _prodsOnt = rule116 arg_nt_ + _prodsOinh = rule117 arg_inh_ + _prodsOsyn = rule118 arg_syn_ + _mergeMap = rule119 _lhsImergeMap arg_nt_ + _aroundMap = rule120 _lhsIaroundMap arg_nt_ + _ntattrs = rule121 arg_inh_ arg_nt_ arg_syn_ + _lhsOntattrs :: Seq (Vertex,NTAttr) + _lhsOntattrs = rule122 _lhsIacount _ntattrs + _lhsOacount :: Int + _lhsOacount = rule123 _lhsIacount arg_inh_ arg_syn_ + _lhsOaranges :: Seq (Int,Int,Int) + _lhsOaranges = rule124 _lhsIacount arg_inh_ arg_syn_ + _lhsOnonts :: [(NontermIdent,[ConstructorIdent])] + _lhsOnonts = rule125 _prodsIcons arg_nt_ + _cInter = rule126 _lhsIcInterfaceMap _lhsIo_dovisit arg_inh_ arg_nt_ arg_syn_ + _lhsOcNonterminal :: CNonterminal + _lhsOcNonterminal = rule127 _cInter _prodsIcProductions arg_inh_ arg_nt_ arg_params_ arg_syn_ + _lhsOmirage :: Mirage.Nonterminal + _lhsOmirage = rule128 _prodsImirages arg_inh_ arg_nt_ arg_params_ arg_syn_ + _lhsOadditionalDep :: Seq Edge + _lhsOadditionalDep = rule129 _prodsIadditionalDep + _lhsOaroundDep :: Seq Edge + _lhsOaroundDep = rule130 _prodsIaroundDep + _lhsOdirectDep :: Seq Edge + _lhsOdirectDep = rule131 _prodsIdirectDep + _lhsOerrors :: Seq Error + _lhsOerrors = rule132 _prodsIerrors + _lhsOinstDep :: Seq Edge + _lhsOinstDep = rule133 _prodsIinstDep + _lhsOmergeDep :: Seq Edge + _lhsOmergeDep = rule134 _prodsImergeDep + _lhsOnAutoRules :: Int + _lhsOnAutoRules = rule135 _prodsInAutoRules + _lhsOnExplicitRules :: Int + _lhsOnExplicitRules = rule136 _prodsInExplicitRules + _lhsOrules :: Seq (Vertex,CRule) + _lhsOrules = rule137 _prodsIrules + _lhsOvcount :: Int + _lhsOvcount = rule138 _prodsIvcount + _prodsOallnts = rule139 _lhsIallnts + _prodsOaroundMap = rule140 _aroundMap + _prodsOcVisitsMap = rule141 _lhsIcVisitsMap + _prodsOinhMap = rule142 _lhsIinhMap + _prodsOmanualAttrDepMap = rule143 _lhsImanualAttrDepMap + _prodsOmergeMap = rule144 _mergeMap + _prodsOo_case = rule145 _lhsIo_case + _prodsOo_cata = rule146 _lhsIo_cata + _prodsOo_dovisit = rule147 _lhsIo_dovisit + _prodsOo_newtypes = rule148 _lhsIo_newtypes + _prodsOo_rename = rule149 _lhsIo_rename + _prodsOo_sem = rule150 _lhsIo_sem + _prodsOo_sig = rule151 _lhsIo_sig + _prodsOo_unbox = rule152 _lhsIo_unbox + _prodsOo_wantvisit = rule153 _lhsIo_wantvisit + _prodsOoptions = rule154 _lhsIoptions + _prodsOprefix = rule155 _lhsIprefix + _prodsOsynMap = rule156 _lhsIsynMap + _prodsOvcount = rule157 _lhsIvcount + __result_ = T_Nonterminal_vOut13 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminal _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount + in __result_ ) + in C_Nonterminal_s14 v13 + {-# INLINE rule114 #-} + {-# LINE 7 "src-ag/DistChildAttr.ag" #-} + rule114 = \ inh_ nt_ -> + {-# LINE 7 "src-ag/DistChildAttr.ag" #-} + Map.singleton nt_ inh_ + {-# LINE 1285 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule115 #-} + {-# LINE 8 "src-ag/DistChildAttr.ag" #-} + rule115 = \ nt_ syn_ -> + {-# LINE 8 "src-ag/DistChildAttr.ag" #-} + Map.singleton nt_ syn_ + {-# LINE 1291 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule116 #-} + {-# LINE 97 "src-ag/Order.ag" #-} + rule116 = \ nt_ -> + {-# LINE 97 "src-ag/Order.ag" #-} + nt_ + {-# LINE 1297 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule117 #-} + {-# LINE 100 "src-ag/Order.ag" #-} + rule117 = \ inh_ -> + {-# LINE 100 "src-ag/Order.ag" #-} + inh_ + {-# LINE 1303 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule118 #-} + {-# LINE 101 "src-ag/Order.ag" #-} + rule118 = \ syn_ -> + {-# LINE 101 "src-ag/Order.ag" #-} + syn_ + {-# LINE 1309 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule119 #-} + {-# LINE 360 "src-ag/Order.ag" #-} + rule119 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) nt_ -> + {-# LINE 360 "src-ag/Order.ag" #-} + Map.findWithDefault Map.empty nt_ _lhsImergeMap + {-# LINE 1315 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule120 #-} + {-# LINE 413 "src-ag/Order.ag" #-} + rule120 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) nt_ -> + {-# LINE 413 "src-ag/Order.ag" #-} + Map.findWithDefault Map.empty nt_ _lhsIaroundMap + {-# LINE 1321 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule121 #-} + {-# LINE 511 "src-ag/Order.ag" #-} + rule121 = \ inh_ nt_ syn_ -> + {-# LINE 511 "src-ag/Order.ag" #-} + [ NTAInh nt_ inh tp | (inh,tp) <- Map.assocs inh_ ] + ++ [NTASyn nt_ syn tp | (syn,tp) <- Map.assocs syn_ ] + {-# LINE 1328 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule122 #-} + {-# LINE 513 "src-ag/Order.ag" #-} + rule122 = \ ((_lhsIacount) :: Int) _ntattrs -> + {-# LINE 513 "src-ag/Order.ag" #-} + Seq.fromList (zip [_lhsIacount ..] _ntattrs) + {-# LINE 1334 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule123 #-} + {-# LINE 514 "src-ag/Order.ag" #-} + rule123 = \ ((_lhsIacount) :: Int) inh_ syn_ -> + {-# LINE 514 "src-ag/Order.ag" #-} + _lhsIacount + Map.size inh_ + Map.size syn_ + {-# LINE 1340 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule124 #-} + {-# LINE 515 "src-ag/Order.ag" #-} + rule124 = \ ((_lhsIacount) :: Int) inh_ syn_ -> + {-# LINE 515 "src-ag/Order.ag" #-} + Seq.singleton + (_lhsIacount + ,_lhsIacount + Map.size inh_ + ,_lhsIacount + Map.size syn_ + Map.size inh_ - 1) + {-# LINE 1349 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule125 #-} + {-# LINE 524 "src-ag/Order.ag" #-} + rule125 = \ ((_prodsIcons) :: [ConstructorIdent]) nt_ -> + {-# LINE 524 "src-ag/Order.ag" #-} + [(nt_,_prodsIcons)] + {-# LINE 1355 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule126 #-} + {-# LINE 601 "src-ag/Order.ag" #-} + rule126 = \ ((_lhsIcInterfaceMap) :: CInterfaceMap) ((_lhsIo_dovisit) :: Bool) inh_ nt_ syn_ -> + {-# LINE 601 "src-ag/Order.ag" #-} + if _lhsIo_dovisit + then findWithErr1 "Nonterminal.cInter" nt_ _lhsIcInterfaceMap + else CInterface [CSegment inh_ syn_] + {-# LINE 1363 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule127 #-} + {-# LINE 629 "src-ag/Order.ag" #-} + rule127 = \ _cInter ((_prodsIcProductions) :: CProductions) inh_ nt_ params_ syn_ -> + {-# LINE 629 "src-ag/Order.ag" #-} + CNonterminal nt_ params_ inh_ syn_ _prodsIcProductions _cInter + {-# LINE 1369 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule128 #-} + {-# LINE 30 "src-ag/TfmToMirage.ag" #-} + rule128 = \ ((_prodsImirages) :: [Mirage.Production]) inh_ nt_ params_ syn_ -> + {-# LINE 30 "src-ag/TfmToMirage.ag" #-} + Mirage.Nonterminal + (getName nt_) + (map getName params_) + (Map.foldrWithKey (\k x xs -> Mirage.Attribute (getName k) (typeToMirage x) : xs) [] inh_) + (Map.foldrWithKey (\k x xs -> Mirage.Attribute (getName k) (typeToMirage x) : xs) [] syn_) + _prodsImirages + {-# LINE 1380 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule129 #-} + rule129 = \ ((_prodsIadditionalDep) :: Seq Edge) -> + _prodsIadditionalDep + {-# INLINE rule130 #-} + rule130 = \ ((_prodsIaroundDep) :: Seq Edge) -> + _prodsIaroundDep + {-# INLINE rule131 #-} + rule131 = \ ((_prodsIdirectDep) :: Seq Edge) -> + _prodsIdirectDep + {-# INLINE rule132 #-} + rule132 = \ ((_prodsIerrors) :: Seq Error) -> + _prodsIerrors + {-# INLINE rule133 #-} + rule133 = \ ((_prodsIinstDep) :: Seq Edge) -> + _prodsIinstDep + {-# INLINE rule134 #-} + rule134 = \ ((_prodsImergeDep) :: Seq Edge) -> + _prodsImergeDep + {-# INLINE rule135 #-} + rule135 = \ ((_prodsInAutoRules) :: Int) -> + _prodsInAutoRules + {-# INLINE rule136 #-} + rule136 = \ ((_prodsInExplicitRules) :: Int) -> + _prodsInExplicitRules + {-# INLINE rule137 #-} + rule137 = \ ((_prodsIrules) :: Seq (Vertex,CRule)) -> + _prodsIrules + {-# INLINE rule138 #-} + rule138 = \ ((_prodsIvcount) :: Int) -> + _prodsIvcount + {-# INLINE rule139 #-} + rule139 = \ ((_lhsIallnts) :: [Identifier]) -> + _lhsIallnts + {-# INLINE rule140 #-} + rule140 = \ _aroundMap -> + _aroundMap + {-# INLINE rule141 #-} + rule141 = \ ((_lhsIcVisitsMap) :: CVisitsMap) -> + _lhsIcVisitsMap + {-# INLINE rule142 #-} + rule142 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> + _lhsIinhMap + {-# INLINE rule143 #-} + rule143 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) -> + _lhsImanualAttrDepMap + {-# INLINE rule144 #-} + rule144 = \ _mergeMap -> + _mergeMap + {-# INLINE rule145 #-} + rule145 = \ ((_lhsIo_case) :: Bool) -> + _lhsIo_case + {-# INLINE rule146 #-} + rule146 = \ ((_lhsIo_cata) :: Bool) -> + _lhsIo_cata + {-# INLINE rule147 #-} + rule147 = \ ((_lhsIo_dovisit) :: Bool) -> + _lhsIo_dovisit + {-# INLINE rule148 #-} + rule148 = \ ((_lhsIo_newtypes) :: Bool) -> + _lhsIo_newtypes + {-# INLINE rule149 #-} + rule149 = \ ((_lhsIo_rename) :: Bool) -> + _lhsIo_rename + {-# INLINE rule150 #-} + rule150 = \ ((_lhsIo_sem) :: Bool) -> + _lhsIo_sem + {-# INLINE rule151 #-} + rule151 = \ ((_lhsIo_sig) :: Bool) -> + _lhsIo_sig + {-# INLINE rule152 #-} + rule152 = \ ((_lhsIo_unbox) :: Bool) -> + _lhsIo_unbox + {-# INLINE rule153 #-} + rule153 = \ ((_lhsIo_wantvisit) :: Bool) -> + _lhsIo_wantvisit + {-# INLINE rule154 #-} + rule154 = \ ((_lhsIoptions) :: Options) -> + _lhsIoptions + {-# INLINE rule155 #-} + rule155 = \ ((_lhsIprefix) :: String) -> + _lhsIprefix + {-# INLINE rule156 #-} + rule156 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> + _lhsIsynMap + {-# INLINE rule157 #-} + rule157 = \ ((_lhsIvcount) :: Int) -> + _lhsIvcount + +-- Nonterminals ------------------------------------------------ +-- wrapper +data Inh_Nonterminals = Inh_Nonterminals { acount_Inh_Nonterminals :: (Int), allnts_Inh_Nonterminals :: ([Identifier]), aroundMap_Inh_Nonterminals :: (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))), cInterfaceMap_Inh_Nonterminals :: (CInterfaceMap), cVisitsMap_Inh_Nonterminals :: (CVisitsMap), inhMap_Inh_Nonterminals :: (Map Identifier Attributes), manualAttrDepMap_Inh_Nonterminals :: (AttrOrderMap), mergeMap_Inh_Nonterminals :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))), o_case_Inh_Nonterminals :: (Bool), o_cata_Inh_Nonterminals :: (Bool), o_data_Inh_Nonterminals :: (Bool), o_dovisit_Inh_Nonterminals :: (Bool), o_newtypes_Inh_Nonterminals :: (Bool), o_rename_Inh_Nonterminals :: (Bool), o_sem_Inh_Nonterminals :: (Bool), o_sig_Inh_Nonterminals :: (Bool), o_unbox_Inh_Nonterminals :: (Bool), o_wantvisit_Inh_Nonterminals :: (Bool), options_Inh_Nonterminals :: (Options), prefix_Inh_Nonterminals :: (String), synMap_Inh_Nonterminals :: (Map Identifier Attributes), vcount_Inh_Nonterminals :: (Int) } +data Syn_Nonterminals = Syn_Nonterminals { acount_Syn_Nonterminals :: (Int), additionalDep_Syn_Nonterminals :: (Seq Edge), aranges_Syn_Nonterminals :: (Seq (Int,Int,Int)), aroundDep_Syn_Nonterminals :: (Seq Edge), cNonterminals_Syn_Nonterminals :: (CNonterminals), directDep_Syn_Nonterminals :: (Seq Edge), errors_Syn_Nonterminals :: (Seq Error), inhMap'_Syn_Nonterminals :: (Map Identifier Attributes), instDep_Syn_Nonterminals :: (Seq Edge), mergeDep_Syn_Nonterminals :: (Seq Edge), mirages_Syn_Nonterminals :: ([Mirage.Nonterminal]), nAutoRules_Syn_Nonterminals :: (Int), nExplicitRules_Syn_Nonterminals :: (Int), nonts_Syn_Nonterminals :: ([(NontermIdent,[ConstructorIdent])]), ntattrs_Syn_Nonterminals :: (Seq (Vertex,NTAttr)), rules_Syn_Nonterminals :: (Seq (Vertex,CRule)), synMap'_Syn_Nonterminals :: (Map Identifier Attributes), vcount_Syn_Nonterminals :: (Int) } +{-# INLINABLE wrap_Nonterminals #-} +wrap_Nonterminals :: T_Nonterminals -> Inh_Nonterminals -> (Syn_Nonterminals ) +wrap_Nonterminals (T_Nonterminals act) (Inh_Nonterminals _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg16 = T_Nonterminals_vIn16 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount + (T_Nonterminals_vOut16 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount) <- return (inv_Nonterminals_s17 sem arg16) + return (Syn_Nonterminals _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount) + ) + +-- cata +{-# NOINLINE sem_Nonterminals #-} +sem_Nonterminals :: Nonterminals -> T_Nonterminals +sem_Nonterminals list = Prelude.foldr sem_Nonterminals_Cons sem_Nonterminals_Nil (Prelude.map sem_Nonterminal list) + +-- semantic domain +newtype T_Nonterminals = T_Nonterminals { + attach_T_Nonterminals :: Identity (T_Nonterminals_s17 ) + } +newtype T_Nonterminals_s17 = C_Nonterminals_s17 { + inv_Nonterminals_s17 :: (T_Nonterminals_v16 ) + } +data T_Nonterminals_s18 = C_Nonterminals_s18 +type T_Nonterminals_v16 = (T_Nonterminals_vIn16 ) -> (T_Nonterminals_vOut16 ) +data T_Nonterminals_vIn16 = T_Nonterminals_vIn16 (Int) ([Identifier]) (Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) (CInterfaceMap) (CVisitsMap) (Map Identifier Attributes) (AttrOrderMap) (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (String) (Map Identifier Attributes) (Int) +data T_Nonterminals_vOut16 = T_Nonterminals_vOut16 (Int) (Seq Edge) (Seq (Int,Int,Int)) (Seq Edge) (CNonterminals) (Seq Edge) (Seq Error) (Map Identifier Attributes) (Seq Edge) (Seq Edge) ([Mirage.Nonterminal]) (Int) (Int) ([(NontermIdent,[ConstructorIdent])]) (Seq (Vertex,NTAttr)) (Seq (Vertex,CRule)) (Map Identifier Attributes) (Int) +{-# NOINLINE sem_Nonterminals_Cons #-} +sem_Nonterminals_Cons :: T_Nonterminal -> T_Nonterminals -> T_Nonterminals +sem_Nonterminals_Cons arg_hd_ arg_tl_ = T_Nonterminals (return st17) where + {-# NOINLINE st17 #-} + st17 = let + v16 :: T_Nonterminals_v16 + v16 = \ (T_Nonterminals_vIn16 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount) -> ( let + _hdX14 = Control.Monad.Identity.runIdentity (attach_T_Nonterminal (arg_hd_)) + _tlX17 = Control.Monad.Identity.runIdentity (attach_T_Nonterminals (arg_tl_)) + (T_Nonterminal_vOut13 _hdIacount _hdIadditionalDep _hdIaranges _hdIaroundDep _hdIcNonterminal _hdIdirectDep _hdIerrors _hdIinhMap' _hdIinstDep _hdImergeDep _hdImirage _hdInAutoRules _hdInExplicitRules _hdInonts _hdIntattrs _hdIrules _hdIsynMap' _hdIvcount) = inv_Nonterminal_s14 _hdX14 (T_Nonterminal_vIn13 _hdOacount _hdOallnts _hdOaroundMap _hdOcInterfaceMap _hdOcVisitsMap _hdOinhMap _hdOmanualAttrDepMap _hdOmergeMap _hdOo_case _hdOo_cata _hdOo_data _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_unbox _hdOo_wantvisit _hdOoptions _hdOprefix _hdOsynMap _hdOvcount) + (T_Nonterminals_vOut16 _tlIacount _tlIadditionalDep _tlIaranges _tlIaroundDep _tlIcNonterminals _tlIdirectDep _tlIerrors _tlIinhMap' _tlIinstDep _tlImergeDep _tlImirages _tlInAutoRules _tlInExplicitRules _tlInonts _tlIntattrs _tlIrules _tlIsynMap' _tlIvcount) = inv_Nonterminals_s17 _tlX17 (T_Nonterminals_vIn16 _tlOacount _tlOallnts _tlOaroundMap _tlOcInterfaceMap _tlOcVisitsMap _tlOinhMap _tlOmanualAttrDepMap _tlOmergeMap _tlOo_case _tlOo_cata _tlOo_data _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_unbox _tlOo_wantvisit _tlOoptions _tlOprefix _tlOsynMap _tlOvcount) + _lhsOcNonterminals :: CNonterminals + _lhsOcNonterminals = rule158 _hdIcNonterminal _tlIcNonterminals + _lhsOmirages :: [Mirage.Nonterminal] + _lhsOmirages = rule159 _hdImirage _tlImirages + _lhsOadditionalDep :: Seq Edge + _lhsOadditionalDep = rule160 _hdIadditionalDep _tlIadditionalDep + _lhsOaranges :: Seq (Int,Int,Int) + _lhsOaranges = rule161 _hdIaranges _tlIaranges + _lhsOaroundDep :: Seq Edge + _lhsOaroundDep = rule162 _hdIaroundDep _tlIaroundDep + _lhsOdirectDep :: Seq Edge + _lhsOdirectDep = rule163 _hdIdirectDep _tlIdirectDep + _lhsOerrors :: Seq Error + _lhsOerrors = rule164 _hdIerrors _tlIerrors + _lhsOinhMap' :: Map Identifier Attributes + _lhsOinhMap' = rule165 _hdIinhMap' _tlIinhMap' + _lhsOinstDep :: Seq Edge + _lhsOinstDep = rule166 _hdIinstDep _tlIinstDep + _lhsOmergeDep :: Seq Edge + _lhsOmergeDep = rule167 _hdImergeDep _tlImergeDep + _lhsOnAutoRules :: Int + _lhsOnAutoRules = rule168 _hdInAutoRules _tlInAutoRules + _lhsOnExplicitRules :: Int + _lhsOnExplicitRules = rule169 _hdInExplicitRules _tlInExplicitRules + _lhsOnonts :: [(NontermIdent,[ConstructorIdent])] + _lhsOnonts = rule170 _hdInonts _tlInonts + _lhsOntattrs :: Seq (Vertex,NTAttr) + _lhsOntattrs = rule171 _hdIntattrs _tlIntattrs + _lhsOrules :: Seq (Vertex,CRule) + _lhsOrules = rule172 _hdIrules _tlIrules + _lhsOsynMap' :: Map Identifier Attributes + _lhsOsynMap' = rule173 _hdIsynMap' _tlIsynMap' + _lhsOacount :: Int + _lhsOacount = rule174 _tlIacount + _lhsOvcount :: Int + _lhsOvcount = rule175 _tlIvcount + _hdOacount = rule176 _lhsIacount + _hdOallnts = rule177 _lhsIallnts + _hdOaroundMap = rule178 _lhsIaroundMap + _hdOcInterfaceMap = rule179 _lhsIcInterfaceMap + _hdOcVisitsMap = rule180 _lhsIcVisitsMap + _hdOinhMap = rule181 _lhsIinhMap + _hdOmanualAttrDepMap = rule182 _lhsImanualAttrDepMap + _hdOmergeMap = rule183 _lhsImergeMap + _hdOo_case = rule184 _lhsIo_case + _hdOo_cata = rule185 _lhsIo_cata + _hdOo_data = rule186 _lhsIo_data + _hdOo_dovisit = rule187 _lhsIo_dovisit + _hdOo_newtypes = rule188 _lhsIo_newtypes + _hdOo_rename = rule189 _lhsIo_rename + _hdOo_sem = rule190 _lhsIo_sem + _hdOo_sig = rule191 _lhsIo_sig + _hdOo_unbox = rule192 _lhsIo_unbox + _hdOo_wantvisit = rule193 _lhsIo_wantvisit + _hdOoptions = rule194 _lhsIoptions + _hdOprefix = rule195 _lhsIprefix + _hdOsynMap = rule196 _lhsIsynMap + _hdOvcount = rule197 _lhsIvcount + _tlOacount = rule198 _hdIacount + _tlOallnts = rule199 _lhsIallnts + _tlOaroundMap = rule200 _lhsIaroundMap + _tlOcInterfaceMap = rule201 _lhsIcInterfaceMap + _tlOcVisitsMap = rule202 _lhsIcVisitsMap + _tlOinhMap = rule203 _lhsIinhMap + _tlOmanualAttrDepMap = rule204 _lhsImanualAttrDepMap + _tlOmergeMap = rule205 _lhsImergeMap + _tlOo_case = rule206 _lhsIo_case + _tlOo_cata = rule207 _lhsIo_cata + _tlOo_data = rule208 _lhsIo_data + _tlOo_dovisit = rule209 _lhsIo_dovisit + _tlOo_newtypes = rule210 _lhsIo_newtypes + _tlOo_rename = rule211 _lhsIo_rename + _tlOo_sem = rule212 _lhsIo_sem + _tlOo_sig = rule213 _lhsIo_sig + _tlOo_unbox = rule214 _lhsIo_unbox + _tlOo_wantvisit = rule215 _lhsIo_wantvisit + _tlOoptions = rule216 _lhsIoptions + _tlOprefix = rule217 _lhsIprefix + _tlOsynMap = rule218 _lhsIsynMap + _tlOvcount = rule219 _hdIvcount + __result_ = T_Nonterminals_vOut16 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount + in __result_ ) + in C_Nonterminals_s17 v16 + {-# INLINE rule158 #-} + {-# LINE 626 "src-ag/Order.ag" #-} + rule158 = \ ((_hdIcNonterminal) :: CNonterminal) ((_tlIcNonterminals) :: CNonterminals) -> + {-# LINE 626 "src-ag/Order.ag" #-} + _hdIcNonterminal : _tlIcNonterminals + {-# LINE 1598 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule159 #-} + {-# LINE 25 "src-ag/TfmToMirage.ag" #-} + rule159 = \ ((_hdImirage) :: Mirage.Nonterminal) ((_tlImirages) :: [Mirage.Nonterminal]) -> + {-# LINE 25 "src-ag/TfmToMirage.ag" #-} + _hdImirage : _tlImirages + {-# LINE 1604 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule160 #-} + rule160 = \ ((_hdIadditionalDep) :: Seq Edge) ((_tlIadditionalDep) :: Seq Edge) -> + _hdIadditionalDep Seq.>< _tlIadditionalDep + {-# INLINE rule161 #-} + rule161 = \ ((_hdIaranges) :: Seq (Int,Int,Int)) ((_tlIaranges) :: Seq (Int,Int,Int)) -> + _hdIaranges Seq.>< _tlIaranges + {-# INLINE rule162 #-} + rule162 = \ ((_hdIaroundDep) :: Seq Edge) ((_tlIaroundDep) :: Seq Edge) -> + _hdIaroundDep Seq.>< _tlIaroundDep + {-# INLINE rule163 #-} + rule163 = \ ((_hdIdirectDep) :: Seq Edge) ((_tlIdirectDep) :: Seq Edge) -> + _hdIdirectDep Seq.>< _tlIdirectDep + {-# INLINE rule164 #-} + rule164 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> + _hdIerrors Seq.>< _tlIerrors + {-# INLINE rule165 #-} + rule165 = \ ((_hdIinhMap') :: Map Identifier Attributes) ((_tlIinhMap') :: Map Identifier Attributes) -> + _hdIinhMap' `Map.union` _tlIinhMap' + {-# INLINE rule166 #-} + rule166 = \ ((_hdIinstDep) :: Seq Edge) ((_tlIinstDep) :: Seq Edge) -> + _hdIinstDep Seq.>< _tlIinstDep + {-# INLINE rule167 #-} + rule167 = \ ((_hdImergeDep) :: Seq Edge) ((_tlImergeDep) :: Seq Edge) -> + _hdImergeDep Seq.>< _tlImergeDep + {-# INLINE rule168 #-} + rule168 = \ ((_hdInAutoRules) :: Int) ((_tlInAutoRules) :: Int) -> + _hdInAutoRules + _tlInAutoRules + {-# INLINE rule169 #-} + rule169 = \ ((_hdInExplicitRules) :: Int) ((_tlInExplicitRules) :: Int) -> + _hdInExplicitRules + _tlInExplicitRules + {-# INLINE rule170 #-} + rule170 = \ ((_hdInonts) :: [(NontermIdent,[ConstructorIdent])]) ((_tlInonts) :: [(NontermIdent,[ConstructorIdent])]) -> + _hdInonts ++ _tlInonts + {-# INLINE rule171 #-} + rule171 = \ ((_hdIntattrs) :: Seq (Vertex,NTAttr)) ((_tlIntattrs) :: Seq (Vertex,NTAttr)) -> + _hdIntattrs Seq.>< _tlIntattrs + {-# INLINE rule172 #-} + rule172 = \ ((_hdIrules) :: Seq (Vertex,CRule)) ((_tlIrules) :: Seq (Vertex,CRule)) -> + _hdIrules Seq.>< _tlIrules + {-# INLINE rule173 #-} + rule173 = \ ((_hdIsynMap') :: Map Identifier Attributes) ((_tlIsynMap') :: Map Identifier Attributes) -> + _hdIsynMap' `Map.union` _tlIsynMap' + {-# INLINE rule174 #-} + rule174 = \ ((_tlIacount) :: Int) -> + _tlIacount + {-# INLINE rule175 #-} + rule175 = \ ((_tlIvcount) :: Int) -> + _tlIvcount + {-# INLINE rule176 #-} + rule176 = \ ((_lhsIacount) :: Int) -> + _lhsIacount + {-# INLINE rule177 #-} + rule177 = \ ((_lhsIallnts) :: [Identifier]) -> + _lhsIallnts + {-# INLINE rule178 #-} + rule178 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> + _lhsIaroundMap + {-# INLINE rule179 #-} + rule179 = \ ((_lhsIcInterfaceMap) :: CInterfaceMap) -> + _lhsIcInterfaceMap + {-# INLINE rule180 #-} + rule180 = \ ((_lhsIcVisitsMap) :: CVisitsMap) -> + _lhsIcVisitsMap + {-# INLINE rule181 #-} + rule181 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> + _lhsIinhMap + {-# INLINE rule182 #-} + rule182 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) -> + _lhsImanualAttrDepMap + {-# INLINE rule183 #-} + rule183 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) -> + _lhsImergeMap + {-# INLINE rule184 #-} + rule184 = \ ((_lhsIo_case) :: Bool) -> + _lhsIo_case + {-# INLINE rule185 #-} + rule185 = \ ((_lhsIo_cata) :: Bool) -> + _lhsIo_cata + {-# INLINE rule186 #-} + rule186 = \ ((_lhsIo_data) :: Bool) -> + _lhsIo_data + {-# INLINE rule187 #-} + rule187 = \ ((_lhsIo_dovisit) :: Bool) -> + _lhsIo_dovisit + {-# INLINE rule188 #-} + rule188 = \ ((_lhsIo_newtypes) :: Bool) -> + _lhsIo_newtypes + {-# INLINE rule189 #-} + rule189 = \ ((_lhsIo_rename) :: Bool) -> + _lhsIo_rename + {-# INLINE rule190 #-} + rule190 = \ ((_lhsIo_sem) :: Bool) -> + _lhsIo_sem + {-# INLINE rule191 #-} + rule191 = \ ((_lhsIo_sig) :: Bool) -> + _lhsIo_sig + {-# INLINE rule192 #-} + rule192 = \ ((_lhsIo_unbox) :: Bool) -> + _lhsIo_unbox + {-# INLINE rule193 #-} + rule193 = \ ((_lhsIo_wantvisit) :: Bool) -> + _lhsIo_wantvisit + {-# INLINE rule194 #-} + rule194 = \ ((_lhsIoptions) :: Options) -> + _lhsIoptions + {-# INLINE rule195 #-} + rule195 = \ ((_lhsIprefix) :: String) -> + _lhsIprefix + {-# INLINE rule196 #-} + rule196 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> + _lhsIsynMap + {-# INLINE rule197 #-} + rule197 = \ ((_lhsIvcount) :: Int) -> + _lhsIvcount + {-# INLINE rule198 #-} + rule198 = \ ((_hdIacount) :: Int) -> + _hdIacount + {-# INLINE rule199 #-} + rule199 = \ ((_lhsIallnts) :: [Identifier]) -> + _lhsIallnts + {-# INLINE rule200 #-} + rule200 = \ ((_lhsIaroundMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression]))) -> + _lhsIaroundMap + {-# INLINE rule201 #-} + rule201 = \ ((_lhsIcInterfaceMap) :: CInterfaceMap) -> + _lhsIcInterfaceMap + {-# INLINE rule202 #-} + rule202 = \ ((_lhsIcVisitsMap) :: CVisitsMap) -> + _lhsIcVisitsMap + {-# INLINE rule203 #-} + rule203 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> + _lhsIinhMap + {-# INLINE rule204 #-} + rule204 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) -> + _lhsImanualAttrDepMap + {-# INLINE rule205 #-} + rule205 = \ ((_lhsImergeMap) :: Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) -> + _lhsImergeMap + {-# INLINE rule206 #-} + rule206 = \ ((_lhsIo_case) :: Bool) -> + _lhsIo_case + {-# INLINE rule207 #-} + rule207 = \ ((_lhsIo_cata) :: Bool) -> + _lhsIo_cata + {-# INLINE rule208 #-} + rule208 = \ ((_lhsIo_data) :: Bool) -> + _lhsIo_data + {-# INLINE rule209 #-} + rule209 = \ ((_lhsIo_dovisit) :: Bool) -> + _lhsIo_dovisit + {-# INLINE rule210 #-} + rule210 = \ ((_lhsIo_newtypes) :: Bool) -> + _lhsIo_newtypes + {-# INLINE rule211 #-} + rule211 = \ ((_lhsIo_rename) :: Bool) -> + _lhsIo_rename + {-# INLINE rule212 #-} + rule212 = \ ((_lhsIo_sem) :: Bool) -> + _lhsIo_sem + {-# INLINE rule213 #-} + rule213 = \ ((_lhsIo_sig) :: Bool) -> + _lhsIo_sig + {-# INLINE rule214 #-} + rule214 = \ ((_lhsIo_unbox) :: Bool) -> + _lhsIo_unbox + {-# INLINE rule215 #-} + rule215 = \ ((_lhsIo_wantvisit) :: Bool) -> + _lhsIo_wantvisit + {-# INLINE rule216 #-} + rule216 = \ ((_lhsIoptions) :: Options) -> + _lhsIoptions + {-# INLINE rule217 #-} + rule217 = \ ((_lhsIprefix) :: String) -> + _lhsIprefix + {-# INLINE rule218 #-} + rule218 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> + _lhsIsynMap + {-# INLINE rule219 #-} + rule219 = \ ((_hdIvcount) :: Int) -> + _hdIvcount +{-# NOINLINE sem_Nonterminals_Nil #-} +sem_Nonterminals_Nil :: T_Nonterminals +sem_Nonterminals_Nil = T_Nonterminals (return st17) where + {-# NOINLINE st17 #-} + st17 = let + v16 :: T_Nonterminals_v16 + v16 = \ (T_Nonterminals_vIn16 _lhsIacount _lhsIallnts _lhsIaroundMap _lhsIcInterfaceMap _lhsIcVisitsMap _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_data _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsynMap _lhsIvcount) -> ( let + _lhsOcNonterminals :: CNonterminals + _lhsOcNonterminals = rule220 () + _lhsOmirages :: [Mirage.Nonterminal] + _lhsOmirages = rule221 () + _lhsOadditionalDep :: Seq Edge + _lhsOadditionalDep = rule222 () + _lhsOaranges :: Seq (Int,Int,Int) + _lhsOaranges = rule223 () + _lhsOaroundDep :: Seq Edge + _lhsOaroundDep = rule224 () + _lhsOdirectDep :: Seq Edge + _lhsOdirectDep = rule225 () + _lhsOerrors :: Seq Error + _lhsOerrors = rule226 () + _lhsOinhMap' :: Map Identifier Attributes + _lhsOinhMap' = rule227 () + _lhsOinstDep :: Seq Edge + _lhsOinstDep = rule228 () + _lhsOmergeDep :: Seq Edge + _lhsOmergeDep = rule229 () + _lhsOnAutoRules :: Int + _lhsOnAutoRules = rule230 () + _lhsOnExplicitRules :: Int + _lhsOnExplicitRules = rule231 () + _lhsOnonts :: [(NontermIdent,[ConstructorIdent])] + _lhsOnonts = rule232 () + _lhsOntattrs :: Seq (Vertex,NTAttr) + _lhsOntattrs = rule233 () + _lhsOrules :: Seq (Vertex,CRule) + _lhsOrules = rule234 () + _lhsOsynMap' :: Map Identifier Attributes + _lhsOsynMap' = rule235 () + _lhsOacount :: Int + _lhsOacount = rule236 _lhsIacount + _lhsOvcount :: Int + _lhsOvcount = rule237 _lhsIvcount + __result_ = T_Nonterminals_vOut16 _lhsOacount _lhsOadditionalDep _lhsOaranges _lhsOaroundDep _lhsOcNonterminals _lhsOdirectDep _lhsOerrors _lhsOinhMap' _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOnonts _lhsOntattrs _lhsOrules _lhsOsynMap' _lhsOvcount + in __result_ ) + in C_Nonterminals_s17 v16 + {-# INLINE rule220 #-} + {-# LINE 627 "src-ag/Order.ag" #-} + rule220 = \ (_ :: ()) -> + {-# LINE 627 "src-ag/Order.ag" #-} + [] + {-# LINE 1836 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule221 #-} + {-# LINE 26 "src-ag/TfmToMirage.ag" #-} + rule221 = \ (_ :: ()) -> + {-# LINE 26 "src-ag/TfmToMirage.ag" #-} + [] + {-# LINE 1842 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule222 #-} + rule222 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule223 #-} + rule223 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule224 #-} + rule224 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule225 #-} + rule225 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule226 #-} + rule226 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule227 #-} + rule227 = \ (_ :: ()) -> + Map.empty + {-# INLINE rule228 #-} + rule228 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule229 #-} + rule229 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule230 #-} + rule230 = \ (_ :: ()) -> + 0 + {-# INLINE rule231 #-} + rule231 = \ (_ :: ()) -> + 0 + {-# INLINE rule232 #-} + rule232 = \ (_ :: ()) -> + [] + {-# INLINE rule233 #-} + rule233 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule234 #-} + rule234 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule235 #-} + rule235 = \ (_ :: ()) -> + Map.empty + {-# INLINE rule236 #-} + rule236 = \ ((_lhsIacount) :: Int) -> + _lhsIacount + {-# INLINE rule237 #-} + rule237 = \ ((_lhsIvcount) :: Int) -> + _lhsIvcount + +-- Pattern ----------------------------------------------------- +-- wrapper +data Inh_Pattern = Inh_Pattern { allTypeSigs_Inh_Pattern :: (Map Identifier Type), altAttrs_Inh_Pattern :: (Map AltAttr Vertex), belowIrrefutable_Inh_Pattern :: (Bool), con_Inh_Pattern :: (Identifier), inh_Inh_Pattern :: (Attributes), nt_Inh_Pattern :: (Identifier), syn_Inh_Pattern :: (Attributes) } +data Syn_Pattern = Syn_Pattern { copy_Syn_Pattern :: (Pattern), errors_Syn_Pattern :: (Seq Error), gathAltAttrs_Syn_Pattern :: ([AltAttr]), instVars_Syn_Pattern :: ([Identifier]), isUnderscore_Syn_Pattern :: (Bool), locVars_Syn_Pattern :: ([Identifier]), patternAttrs_Syn_Pattern :: ([(Identifier,Identifier,Bool)]), pp_Syn_Pattern :: (PP_Doc) } +{-# INLINABLE wrap_Pattern #-} +wrap_Pattern :: T_Pattern -> Inh_Pattern -> (Syn_Pattern ) +wrap_Pattern (T_Pattern act) (Inh_Pattern _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg19 = T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn + (T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp) <- return (inv_Pattern_s20 sem arg19) + return (Syn_Pattern _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp) + ) + +-- cata +{-# NOINLINE sem_Pattern #-} +sem_Pattern :: Pattern -> T_Pattern +sem_Pattern ( Constr name_ pats_ ) = sem_Pattern_Constr name_ ( sem_Patterns pats_ ) +sem_Pattern ( Product pos_ pats_ ) = sem_Pattern_Product pos_ ( sem_Patterns pats_ ) +sem_Pattern ( Alias field_ attr_ pat_ ) = sem_Pattern_Alias field_ attr_ ( sem_Pattern pat_ ) +sem_Pattern ( Irrefutable pat_ ) = sem_Pattern_Irrefutable ( sem_Pattern pat_ ) +sem_Pattern ( Underscore pos_ ) = sem_Pattern_Underscore pos_ + +-- semantic domain +newtype T_Pattern = T_Pattern { + attach_T_Pattern :: Identity (T_Pattern_s20 ) + } +newtype T_Pattern_s20 = C_Pattern_s20 { + inv_Pattern_s20 :: (T_Pattern_v19 ) + } +data T_Pattern_s21 = C_Pattern_s21 +type T_Pattern_v19 = (T_Pattern_vIn19 ) -> (T_Pattern_vOut19 ) +data T_Pattern_vIn19 = T_Pattern_vIn19 (Map Identifier Type) (Map AltAttr Vertex) (Bool) (Identifier) (Attributes) (Identifier) (Attributes) +data T_Pattern_vOut19 = T_Pattern_vOut19 (Pattern) (Seq Error) ([AltAttr]) ([Identifier]) (Bool) ([Identifier]) ([(Identifier,Identifier,Bool)]) (PP_Doc) +{-# NOINLINE sem_Pattern_Constr #-} +sem_Pattern_Constr :: (ConstructorIdent) -> T_Patterns -> T_Pattern +sem_Pattern_Constr arg_name_ arg_pats_ = T_Pattern (return st20) where + {-# NOINLINE st20 #-} + st20 = let + v19 :: T_Pattern_v19 + v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let + _patsX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) + (T_Patterns_vOut22 _patsIcopy _patsIerrors _patsIgathAltAttrs _patsIinstVars _patsIlocVars _patsIpatternAttrs _patsIpps) = inv_Patterns_s23 _patsX23 (T_Patterns_vIn22 _patsOallTypeSigs _patsOaltAttrs _patsObelowIrrefutable _patsOcon _patsOinh _patsOnt _patsOsyn) + _lhsOpp :: PP_Doc + _lhsOpp = rule238 _patsIpps arg_name_ + _lhsOisUnderscore :: Bool + _lhsOisUnderscore = rule239 () + _lhsOerrors :: Seq Error + _lhsOerrors = rule240 _patsIerrors + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule241 _patsIgathAltAttrs + _lhsOinstVars :: [Identifier] + _lhsOinstVars = rule242 _patsIinstVars + _lhsOlocVars :: [Identifier] + _lhsOlocVars = rule243 _patsIlocVars + _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] + _lhsOpatternAttrs = rule244 _patsIpatternAttrs + _copy = rule245 _patsIcopy arg_name_ + _lhsOcopy :: Pattern + _lhsOcopy = rule246 _copy + _patsOallTypeSigs = rule247 _lhsIallTypeSigs + _patsOaltAttrs = rule248 _lhsIaltAttrs + _patsObelowIrrefutable = rule249 _lhsIbelowIrrefutable + _patsOcon = rule250 _lhsIcon + _patsOinh = rule251 _lhsIinh + _patsOnt = rule252 _lhsInt + _patsOsyn = rule253 _lhsIsyn + __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp + in __result_ ) + in C_Pattern_s20 v19 + {-# INLINE rule238 #-} + {-# LINE 80 "src-ag/TfmToMirage.ag" #-} + rule238 = \ ((_patsIpps) :: [PP_Doc]) name_ -> + {-# LINE 80 "src-ag/TfmToMirage.ag" #-} + pp_parens $ name_ >#< hv_sp _patsIpps + {-# LINE 1967 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule239 #-} + {-# LINE 91 "src-ag/TfmToMirage.ag" #-} + rule239 = \ (_ :: ()) -> + {-# LINE 91 "src-ag/TfmToMirage.ag" #-} + False + {-# LINE 1973 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule240 #-} + rule240 = \ ((_patsIerrors) :: Seq Error) -> + _patsIerrors + {-# INLINE rule241 #-} + rule241 = \ ((_patsIgathAltAttrs) :: [AltAttr]) -> + _patsIgathAltAttrs + {-# INLINE rule242 #-} + rule242 = \ ((_patsIinstVars) :: [Identifier]) -> + _patsIinstVars + {-# INLINE rule243 #-} + rule243 = \ ((_patsIlocVars) :: [Identifier]) -> + _patsIlocVars + {-# INLINE rule244 #-} + rule244 = \ ((_patsIpatternAttrs) :: [(Identifier,Identifier,Bool)]) -> + _patsIpatternAttrs + {-# INLINE rule245 #-} + rule245 = \ ((_patsIcopy) :: Patterns) name_ -> + Constr name_ _patsIcopy + {-# INLINE rule246 #-} + rule246 = \ _copy -> + _copy + {-# INLINE rule247 #-} + rule247 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> + _lhsIallTypeSigs + {-# INLINE rule248 #-} + rule248 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> + _lhsIaltAttrs + {-# INLINE rule249 #-} + rule249 = \ ((_lhsIbelowIrrefutable) :: Bool) -> + _lhsIbelowIrrefutable + {-# INLINE rule250 #-} + rule250 = \ ((_lhsIcon) :: Identifier) -> + _lhsIcon + {-# INLINE rule251 #-} + rule251 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule252 #-} + rule252 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule253 #-} + rule253 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn +{-# NOINLINE sem_Pattern_Product #-} +sem_Pattern_Product :: (Pos) -> T_Patterns -> T_Pattern +sem_Pattern_Product arg_pos_ arg_pats_ = T_Pattern (return st20) where + {-# NOINLINE st20 #-} + st20 = let + v19 :: T_Pattern_v19 + v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let + _patsX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_pats_)) + (T_Patterns_vOut22 _patsIcopy _patsIerrors _patsIgathAltAttrs _patsIinstVars _patsIlocVars _patsIpatternAttrs _patsIpps) = inv_Patterns_s23 _patsX23 (T_Patterns_vIn22 _patsOallTypeSigs _patsOaltAttrs _patsObelowIrrefutable _patsOcon _patsOinh _patsOnt _patsOsyn) + _lhsOpp :: PP_Doc + _lhsOpp = rule254 _patsIpps + _lhsOisUnderscore :: Bool + _lhsOisUnderscore = rule255 () + _lhsOerrors :: Seq Error + _lhsOerrors = rule256 _patsIerrors + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule257 _patsIgathAltAttrs + _lhsOinstVars :: [Identifier] + _lhsOinstVars = rule258 _patsIinstVars + _lhsOlocVars :: [Identifier] + _lhsOlocVars = rule259 _patsIlocVars + _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] + _lhsOpatternAttrs = rule260 _patsIpatternAttrs + _copy = rule261 _patsIcopy arg_pos_ + _lhsOcopy :: Pattern + _lhsOcopy = rule262 _copy + _patsOallTypeSigs = rule263 _lhsIallTypeSigs + _patsOaltAttrs = rule264 _lhsIaltAttrs + _patsObelowIrrefutable = rule265 _lhsIbelowIrrefutable + _patsOcon = rule266 _lhsIcon + _patsOinh = rule267 _lhsIinh + _patsOnt = rule268 _lhsInt + _patsOsyn = rule269 _lhsIsyn + __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp + in __result_ ) + in C_Pattern_s20 v19 + {-# INLINE rule254 #-} + {-# LINE 81 "src-ag/TfmToMirage.ag" #-} + rule254 = \ ((_patsIpps) :: [PP_Doc]) -> + {-# LINE 81 "src-ag/TfmToMirage.ag" #-} + pp_block "(" ")" "," _patsIpps + {-# LINE 2057 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule255 #-} + {-# LINE 92 "src-ag/TfmToMirage.ag" #-} + rule255 = \ (_ :: ()) -> + {-# LINE 92 "src-ag/TfmToMirage.ag" #-} + False + {-# LINE 2063 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule256 #-} + rule256 = \ ((_patsIerrors) :: Seq Error) -> + _patsIerrors + {-# INLINE rule257 #-} + rule257 = \ ((_patsIgathAltAttrs) :: [AltAttr]) -> + _patsIgathAltAttrs + {-# INLINE rule258 #-} + rule258 = \ ((_patsIinstVars) :: [Identifier]) -> + _patsIinstVars + {-# INLINE rule259 #-} + rule259 = \ ((_patsIlocVars) :: [Identifier]) -> + _patsIlocVars + {-# INLINE rule260 #-} + rule260 = \ ((_patsIpatternAttrs) :: [(Identifier,Identifier,Bool)]) -> + _patsIpatternAttrs + {-# INLINE rule261 #-} + rule261 = \ ((_patsIcopy) :: Patterns) pos_ -> + Product pos_ _patsIcopy + {-# INLINE rule262 #-} + rule262 = \ _copy -> + _copy + {-# INLINE rule263 #-} + rule263 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> + _lhsIallTypeSigs + {-# INLINE rule264 #-} + rule264 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> + _lhsIaltAttrs + {-# INLINE rule265 #-} + rule265 = \ ((_lhsIbelowIrrefutable) :: Bool) -> + _lhsIbelowIrrefutable + {-# INLINE rule266 #-} + rule266 = \ ((_lhsIcon) :: Identifier) -> + _lhsIcon + {-# INLINE rule267 #-} + rule267 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule268 #-} + rule268 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule269 #-} + rule269 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn +{-# NOINLINE sem_Pattern_Alias #-} +sem_Pattern_Alias :: (Identifier) -> (Identifier) -> T_Pattern -> T_Pattern +sem_Pattern_Alias arg_field_ arg_attr_ arg_pat_ = T_Pattern (return st20) where + {-# NOINLINE st20 #-} + st20 = let + v19 :: T_Pattern_v19 + v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let + _patX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) + (T_Pattern_vOut19 _patIcopy _patIerrors _patIgathAltAttrs _patIinstVars _patIisUnderscore _patIlocVars _patIpatternAttrs _patIpp) = inv_Pattern_s20 _patX20 (T_Pattern_vIn19 _patOallTypeSigs _patOaltAttrs _patObelowIrrefutable _patOcon _patOinh _patOnt _patOsyn) + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule270 arg_attr_ arg_field_ + _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] + _lhsOpatternAttrs = rule271 arg_attr_ arg_field_ + _lhsOlocVars :: [Identifier] + _lhsOlocVars = rule272 arg_attr_ arg_field_ + _lhsOinstVars :: [Identifier] + _lhsOinstVars = rule273 arg_attr_ arg_field_ + _ppVar = rule274 arg_attr_ arg_field_ + _ppVarBang = rule275 _ppVar + _lhsOpp :: PP_Doc + _lhsOpp = rule276 _patIisUnderscore _patIpp _ppVarBang + _lhsOisUnderscore :: Bool + _lhsOisUnderscore = rule277 () + _lhsOerrors :: Seq Error + _lhsOerrors = rule278 _patIerrors + _copy = rule279 _patIcopy arg_attr_ arg_field_ + _lhsOcopy :: Pattern + _lhsOcopy = rule280 _copy + _patOallTypeSigs = rule281 _lhsIallTypeSigs + _patOaltAttrs = rule282 _lhsIaltAttrs + _patObelowIrrefutable = rule283 _lhsIbelowIrrefutable + _patOcon = rule284 _lhsIcon + _patOinh = rule285 _lhsIinh + _patOnt = rule286 _lhsInt + _patOsyn = rule287 _lhsIsyn + __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp + in __result_ ) + in C_Pattern_s20 v19 + {-# INLINE rule270 #-} + {-# LINE 187 "src-ag/Order.ag" #-} + rule270 = \ attr_ field_ -> + {-# LINE 187 "src-ag/Order.ag" #-} + [AltAttr field_ attr_ (field_ == _LOC || field_ == _INST)] + {-# LINE 2149 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule271 #-} + {-# LINE 253 "src-ag/Order.ag" #-} + rule271 = \ attr_ field_ -> + {-# LINE 253 "src-ag/Order.ag" #-} + [(field_,attr_,(field_ == _LOC || field_ == _INST))] + {-# LINE 2155 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule272 #-} + {-# LINE 685 "src-ag/Order.ag" #-} + rule272 = \ attr_ field_ -> + {-# LINE 685 "src-ag/Order.ag" #-} + if field_ == _LOC + then [attr_] + else [] + {-# LINE 2163 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule273 #-} + {-# LINE 688 "src-ag/Order.ag" #-} + rule273 = \ attr_ field_ -> + {-# LINE 688 "src-ag/Order.ag" #-} + if field_ == _INST + then [attr_] + else [] + {-# LINE 2171 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule274 #-} + {-# LINE 82 "src-ag/TfmToMirage.ag" #-} + rule274 = \ attr_ field_ -> + {-# LINE 82 "src-ag/TfmToMirage.ag" #-} + pp field_ >|< "." >|< pp attr_ + {-# LINE 2177 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule275 #-} + {-# LINE 83 "src-ag/TfmToMirage.ag" #-} + rule275 = \ _ppVar -> + {-# LINE 83 "src-ag/TfmToMirage.ag" #-} + _ppVar + {-# LINE 2183 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule276 #-} + {-# LINE 84 "src-ag/TfmToMirage.ag" #-} + rule276 = \ ((_patIisUnderscore) :: Bool) ((_patIpp) :: PP_Doc) _ppVarBang -> + {-# LINE 84 "src-ag/TfmToMirage.ag" #-} + if _patIisUnderscore + then _ppVarBang + else _ppVarBang >|< "@" >|< _patIpp + {-# LINE 2191 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule277 #-} + {-# LINE 93 "src-ag/TfmToMirage.ag" #-} + rule277 = \ (_ :: ()) -> + {-# LINE 93 "src-ag/TfmToMirage.ag" #-} + False + {-# LINE 2197 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule278 #-} + rule278 = \ ((_patIerrors) :: Seq Error) -> + _patIerrors + {-# INLINE rule279 #-} + rule279 = \ ((_patIcopy) :: Pattern) attr_ field_ -> + Alias field_ attr_ _patIcopy + {-# INLINE rule280 #-} + rule280 = \ _copy -> + _copy + {-# INLINE rule281 #-} + rule281 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> + _lhsIallTypeSigs + {-# INLINE rule282 #-} + rule282 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> + _lhsIaltAttrs + {-# INLINE rule283 #-} + rule283 = \ ((_lhsIbelowIrrefutable) :: Bool) -> + _lhsIbelowIrrefutable + {-# INLINE rule284 #-} + rule284 = \ ((_lhsIcon) :: Identifier) -> + _lhsIcon + {-# INLINE rule285 #-} + rule285 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule286 #-} + rule286 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule287 #-} + rule287 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn +{-# NOINLINE sem_Pattern_Irrefutable #-} +sem_Pattern_Irrefutable :: T_Pattern -> T_Pattern +sem_Pattern_Irrefutable arg_pat_ = T_Pattern (return st20) where + {-# NOINLINE st20 #-} + st20 = let + v19 :: T_Pattern_v19 + v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let + _patX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pat_)) + (T_Pattern_vOut19 _patIcopy _patIerrors _patIgathAltAttrs _patIinstVars _patIisUnderscore _patIlocVars _patIpatternAttrs _patIpp) = inv_Pattern_s20 _patX20 (T_Pattern_vIn19 _patOallTypeSigs _patOaltAttrs _patObelowIrrefutable _patOcon _patOinh _patOnt _patOsyn) + _lhsOpp :: PP_Doc + _lhsOpp = rule288 _patIpp + _patObelowIrrefutable = rule289 () + _lhsOerrors :: Seq Error + _lhsOerrors = rule290 _patIerrors + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule291 _patIgathAltAttrs + _lhsOinstVars :: [Identifier] + _lhsOinstVars = rule292 _patIinstVars + _lhsOlocVars :: [Identifier] + _lhsOlocVars = rule293 _patIlocVars + _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] + _lhsOpatternAttrs = rule294 _patIpatternAttrs + _copy = rule295 _patIcopy + _lhsOcopy :: Pattern + _lhsOcopy = rule296 _copy + _lhsOisUnderscore :: Bool + _lhsOisUnderscore = rule297 _patIisUnderscore + _patOallTypeSigs = rule298 _lhsIallTypeSigs + _patOaltAttrs = rule299 _lhsIaltAttrs + _patOcon = rule300 _lhsIcon + _patOinh = rule301 _lhsIinh + _patOnt = rule302 _lhsInt + _patOsyn = rule303 _lhsIsyn + __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp + in __result_ ) + in C_Pattern_s20 v19 + {-# INLINE rule288 #-} + {-# LINE 87 "src-ag/TfmToMirage.ag" #-} + rule288 = \ ((_patIpp) :: PP_Doc) -> + {-# LINE 87 "src-ag/TfmToMirage.ag" #-} + text "~" >|< pp_parens _patIpp + {-# LINE 2269 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule289 #-} + {-# LINE 100 "src-ag/TfmToMirage.ag" #-} + rule289 = \ (_ :: ()) -> + {-# LINE 100 "src-ag/TfmToMirage.ag" #-} + True + {-# LINE 2275 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule290 #-} + rule290 = \ ((_patIerrors) :: Seq Error) -> + _patIerrors + {-# INLINE rule291 #-} + rule291 = \ ((_patIgathAltAttrs) :: [AltAttr]) -> + _patIgathAltAttrs + {-# INLINE rule292 #-} + rule292 = \ ((_patIinstVars) :: [Identifier]) -> + _patIinstVars + {-# INLINE rule293 #-} + rule293 = \ ((_patIlocVars) :: [Identifier]) -> + _patIlocVars + {-# INLINE rule294 #-} + rule294 = \ ((_patIpatternAttrs) :: [(Identifier,Identifier,Bool)]) -> + _patIpatternAttrs + {-# INLINE rule295 #-} + rule295 = \ ((_patIcopy) :: Pattern) -> + Irrefutable _patIcopy + {-# INLINE rule296 #-} + rule296 = \ _copy -> + _copy + {-# INLINE rule297 #-} + rule297 = \ ((_patIisUnderscore) :: Bool) -> + _patIisUnderscore + {-# INLINE rule298 #-} + rule298 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> + _lhsIallTypeSigs + {-# INLINE rule299 #-} + rule299 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> + _lhsIaltAttrs + {-# INLINE rule300 #-} + rule300 = \ ((_lhsIcon) :: Identifier) -> + _lhsIcon + {-# INLINE rule301 #-} + rule301 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule302 #-} + rule302 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule303 #-} + rule303 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn +{-# NOINLINE sem_Pattern_Underscore #-} +sem_Pattern_Underscore :: (Pos) -> T_Pattern +sem_Pattern_Underscore arg_pos_ = T_Pattern (return st20) where + {-# NOINLINE st20 #-} + st20 = let + v19 :: T_Pattern_v19 + v19 = \ (T_Pattern_vIn19 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let + _lhsOpp :: PP_Doc + _lhsOpp = rule304 () + _lhsOisUnderscore :: Bool + _lhsOisUnderscore = rule305 () + _lhsOerrors :: Seq Error + _lhsOerrors = rule306 () + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule307 () + _lhsOinstVars :: [Identifier] + _lhsOinstVars = rule308 () + _lhsOlocVars :: [Identifier] + _lhsOlocVars = rule309 () + _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] + _lhsOpatternAttrs = rule310 () + _copy = rule311 arg_pos_ + _lhsOcopy :: Pattern + _lhsOcopy = rule312 _copy + __result_ = T_Pattern_vOut19 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOisUnderscore _lhsOlocVars _lhsOpatternAttrs _lhsOpp + in __result_ ) + in C_Pattern_s20 v19 + {-# INLINE rule304 #-} + {-# LINE 88 "src-ag/TfmToMirage.ag" #-} + rule304 = \ (_ :: ()) -> + {-# LINE 88 "src-ag/TfmToMirage.ag" #-} + text "_" + {-# LINE 2350 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule305 #-} + {-# LINE 94 "src-ag/TfmToMirage.ag" #-} + rule305 = \ (_ :: ()) -> + {-# LINE 94 "src-ag/TfmToMirage.ag" #-} + True + {-# LINE 2356 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule306 #-} + rule306 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule307 #-} + rule307 = \ (_ :: ()) -> + [] + {-# INLINE rule308 #-} + rule308 = \ (_ :: ()) -> + [] + {-# INLINE rule309 #-} + rule309 = \ (_ :: ()) -> + [] + {-# INLINE rule310 #-} + rule310 = \ (_ :: ()) -> + [] + {-# INLINE rule311 #-} + rule311 = \ pos_ -> + Underscore pos_ + {-# INLINE rule312 #-} + rule312 = \ _copy -> + _copy + +-- Patterns ---------------------------------------------------- +-- wrapper +data Inh_Patterns = Inh_Patterns { allTypeSigs_Inh_Patterns :: (Map Identifier Type), altAttrs_Inh_Patterns :: (Map AltAttr Vertex), belowIrrefutable_Inh_Patterns :: (Bool), con_Inh_Patterns :: (Identifier), inh_Inh_Patterns :: (Attributes), nt_Inh_Patterns :: (Identifier), syn_Inh_Patterns :: (Attributes) } +data Syn_Patterns = Syn_Patterns { copy_Syn_Patterns :: (Patterns), errors_Syn_Patterns :: (Seq Error), gathAltAttrs_Syn_Patterns :: ([AltAttr]), instVars_Syn_Patterns :: ([Identifier]), locVars_Syn_Patterns :: ([Identifier]), patternAttrs_Syn_Patterns :: ([(Identifier,Identifier,Bool)]), pps_Syn_Patterns :: ([PP_Doc]) } +{-# INLINABLE wrap_Patterns #-} +wrap_Patterns :: T_Patterns -> Inh_Patterns -> (Syn_Patterns ) +wrap_Patterns (T_Patterns act) (Inh_Patterns _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg22 = T_Patterns_vIn22 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn + (T_Patterns_vOut22 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs _lhsOpps) <- return (inv_Patterns_s23 sem arg22) + return (Syn_Patterns _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs _lhsOpps) + ) + +-- cata +{-# NOINLINE sem_Patterns #-} +sem_Patterns :: Patterns -> T_Patterns +sem_Patterns list = Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list) + +-- semantic domain +newtype T_Patterns = T_Patterns { + attach_T_Patterns :: Identity (T_Patterns_s23 ) + } +newtype T_Patterns_s23 = C_Patterns_s23 { + inv_Patterns_s23 :: (T_Patterns_v22 ) + } +data T_Patterns_s24 = C_Patterns_s24 +type T_Patterns_v22 = (T_Patterns_vIn22 ) -> (T_Patterns_vOut22 ) +data T_Patterns_vIn22 = T_Patterns_vIn22 (Map Identifier Type) (Map AltAttr Vertex) (Bool) (Identifier) (Attributes) (Identifier) (Attributes) +data T_Patterns_vOut22 = T_Patterns_vOut22 (Patterns) (Seq Error) ([AltAttr]) ([Identifier]) ([Identifier]) ([(Identifier,Identifier,Bool)]) ([PP_Doc]) +{-# NOINLINE sem_Patterns_Cons #-} +sem_Patterns_Cons :: T_Pattern -> T_Patterns -> T_Patterns +sem_Patterns_Cons arg_hd_ arg_tl_ = T_Patterns (return st23) where + {-# NOINLINE st23 #-} + st23 = let + v22 :: T_Patterns_v22 + v22 = \ (T_Patterns_vIn22 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let + _hdX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_hd_)) + _tlX23 = Control.Monad.Identity.runIdentity (attach_T_Patterns (arg_tl_)) + (T_Pattern_vOut19 _hdIcopy _hdIerrors _hdIgathAltAttrs _hdIinstVars _hdIisUnderscore _hdIlocVars _hdIpatternAttrs _hdIpp) = inv_Pattern_s20 _hdX20 (T_Pattern_vIn19 _hdOallTypeSigs _hdOaltAttrs _hdObelowIrrefutable _hdOcon _hdOinh _hdOnt _hdOsyn) + (T_Patterns_vOut22 _tlIcopy _tlIerrors _tlIgathAltAttrs _tlIinstVars _tlIlocVars _tlIpatternAttrs _tlIpps) = inv_Patterns_s23 _tlX23 (T_Patterns_vIn22 _tlOallTypeSigs _tlOaltAttrs _tlObelowIrrefutable _tlOcon _tlOinh _tlOnt _tlOsyn) + _lhsOpps :: [PP_Doc] + _lhsOpps = rule313 _hdIpp _tlIpps + _lhsOerrors :: Seq Error + _lhsOerrors = rule314 _hdIerrors _tlIerrors + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule315 _hdIgathAltAttrs _tlIgathAltAttrs + _lhsOinstVars :: [Identifier] + _lhsOinstVars = rule316 _hdIinstVars _tlIinstVars + _lhsOlocVars :: [Identifier] + _lhsOlocVars = rule317 _hdIlocVars _tlIlocVars + _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] + _lhsOpatternAttrs = rule318 _hdIpatternAttrs _tlIpatternAttrs + _copy = rule319 _hdIcopy _tlIcopy + _lhsOcopy :: Patterns + _lhsOcopy = rule320 _copy + _hdOallTypeSigs = rule321 _lhsIallTypeSigs + _hdOaltAttrs = rule322 _lhsIaltAttrs + _hdObelowIrrefutable = rule323 _lhsIbelowIrrefutable + _hdOcon = rule324 _lhsIcon + _hdOinh = rule325 _lhsIinh + _hdOnt = rule326 _lhsInt + _hdOsyn = rule327 _lhsIsyn + _tlOallTypeSigs = rule328 _lhsIallTypeSigs + _tlOaltAttrs = rule329 _lhsIaltAttrs + _tlObelowIrrefutable = rule330 _lhsIbelowIrrefutable + _tlOcon = rule331 _lhsIcon + _tlOinh = rule332 _lhsIinh + _tlOnt = rule333 _lhsInt + _tlOsyn = rule334 _lhsIsyn + __result_ = T_Patterns_vOut22 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs _lhsOpps + in __result_ ) + in C_Patterns_s23 v22 + {-# INLINE rule313 #-} + {-# LINE 76 "src-ag/TfmToMirage.ag" #-} + rule313 = \ ((_hdIpp) :: PP_Doc) ((_tlIpps) :: [PP_Doc]) -> + {-# LINE 76 "src-ag/TfmToMirage.ag" #-} + _hdIpp : _tlIpps + {-# LINE 2457 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule314 #-} + rule314 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> + _hdIerrors Seq.>< _tlIerrors + {-# INLINE rule315 #-} + rule315 = \ ((_hdIgathAltAttrs) :: [AltAttr]) ((_tlIgathAltAttrs) :: [AltAttr]) -> + _hdIgathAltAttrs ++ _tlIgathAltAttrs + {-# INLINE rule316 #-} + rule316 = \ ((_hdIinstVars) :: [Identifier]) ((_tlIinstVars) :: [Identifier]) -> + _hdIinstVars ++ _tlIinstVars + {-# INLINE rule317 #-} + rule317 = \ ((_hdIlocVars) :: [Identifier]) ((_tlIlocVars) :: [Identifier]) -> + _hdIlocVars ++ _tlIlocVars + {-# INLINE rule318 #-} + rule318 = \ ((_hdIpatternAttrs) :: [(Identifier,Identifier,Bool)]) ((_tlIpatternAttrs) :: [(Identifier,Identifier,Bool)]) -> + _hdIpatternAttrs ++ _tlIpatternAttrs + {-# INLINE rule319 #-} + rule319 = \ ((_hdIcopy) :: Pattern) ((_tlIcopy) :: Patterns) -> + (:) _hdIcopy _tlIcopy + {-# INLINE rule320 #-} + rule320 = \ _copy -> + _copy + {-# INLINE rule321 #-} + rule321 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> + _lhsIallTypeSigs + {-# INLINE rule322 #-} + rule322 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> + _lhsIaltAttrs + {-# INLINE rule323 #-} + rule323 = \ ((_lhsIbelowIrrefutable) :: Bool) -> + _lhsIbelowIrrefutable + {-# INLINE rule324 #-} + rule324 = \ ((_lhsIcon) :: Identifier) -> + _lhsIcon + {-# INLINE rule325 #-} + rule325 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule326 #-} + rule326 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule327 #-} + rule327 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn + {-# INLINE rule328 #-} + rule328 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> + _lhsIallTypeSigs + {-# INLINE rule329 #-} + rule329 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> + _lhsIaltAttrs + {-# INLINE rule330 #-} + rule330 = \ ((_lhsIbelowIrrefutable) :: Bool) -> + _lhsIbelowIrrefutable + {-# INLINE rule331 #-} + rule331 = \ ((_lhsIcon) :: Identifier) -> + _lhsIcon + {-# INLINE rule332 #-} + rule332 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule333 #-} + rule333 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule334 #-} + rule334 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn +{-# NOINLINE sem_Patterns_Nil #-} +sem_Patterns_Nil :: T_Patterns +sem_Patterns_Nil = T_Patterns (return st23) where + {-# NOINLINE st23 #-} + st23 = let + v22 :: T_Patterns_v22 + v22 = \ (T_Patterns_vIn22 _lhsIallTypeSigs _lhsIaltAttrs _lhsIbelowIrrefutable _lhsIcon _lhsIinh _lhsInt _lhsIsyn) -> ( let + _lhsOpps :: [PP_Doc] + _lhsOpps = rule335 () + _lhsOerrors :: Seq Error + _lhsOerrors = rule336 () + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule337 () + _lhsOinstVars :: [Identifier] + _lhsOinstVars = rule338 () + _lhsOlocVars :: [Identifier] + _lhsOlocVars = rule339 () + _lhsOpatternAttrs :: [(Identifier,Identifier,Bool)] + _lhsOpatternAttrs = rule340 () + _copy = rule341 () + _lhsOcopy :: Patterns + _lhsOcopy = rule342 _copy + __result_ = T_Patterns_vOut22 _lhsOcopy _lhsOerrors _lhsOgathAltAttrs _lhsOinstVars _lhsOlocVars _lhsOpatternAttrs _lhsOpps + in __result_ ) + in C_Patterns_s23 v22 + {-# INLINE rule335 #-} + {-# LINE 77 "src-ag/TfmToMirage.ag" #-} + rule335 = \ (_ :: ()) -> + {-# LINE 77 "src-ag/TfmToMirage.ag" #-} + [] + {-# LINE 2551 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule336 #-} + rule336 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule337 #-} + rule337 = \ (_ :: ()) -> + [] + {-# INLINE rule338 #-} + rule338 = \ (_ :: ()) -> + [] + {-# INLINE rule339 #-} + rule339 = \ (_ :: ()) -> + [] + {-# INLINE rule340 #-} + rule340 = \ (_ :: ()) -> + [] + {-# INLINE rule341 #-} + rule341 = \ (_ :: ()) -> + [] + {-# INLINE rule342 #-} + rule342 = \ _copy -> + _copy + +-- Production -------------------------------------------------- +-- wrapper +data Inh_Production = Inh_Production { allnts_Inh_Production :: ([Identifier]), aroundMap_Inh_Production :: (Map ConstructorIdent (Map Identifier [Expression])), cVisitsMap_Inh_Production :: (CVisitsMap), inh_Inh_Production :: (Attributes), inhMap_Inh_Production :: (Map Identifier Attributes), manualAttrDepMap_Inh_Production :: (AttrOrderMap), mergeMap_Inh_Production :: (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))), nt_Inh_Production :: (Identifier), o_case_Inh_Production :: (Bool), o_cata_Inh_Production :: (Bool), o_dovisit_Inh_Production :: (Bool), o_newtypes_Inh_Production :: (Bool), o_rename_Inh_Production :: (Bool), o_sem_Inh_Production :: (Bool), o_sig_Inh_Production :: (Bool), o_unbox_Inh_Production :: (Bool), o_wantvisit_Inh_Production :: (Bool), options_Inh_Production :: (Options), prefix_Inh_Production :: (String), syn_Inh_Production :: (Attributes), synMap_Inh_Production :: (Map Identifier Attributes), vcount_Inh_Production :: (Int) } +data Syn_Production = Syn_Production { additionalDep_Syn_Production :: (Seq Edge), aroundDep_Syn_Production :: (Seq Edge), cProduction_Syn_Production :: (CProduction), cons_Syn_Production :: ([ConstructorIdent]), directDep_Syn_Production :: (Seq Edge), errors_Syn_Production :: (Seq Error), instDep_Syn_Production :: (Seq Edge), mergeDep_Syn_Production :: (Seq Edge), mirage_Syn_Production :: (Mirage.Production), nAutoRules_Syn_Production :: (Int), nExplicitRules_Syn_Production :: (Int), rules_Syn_Production :: (Seq (Vertex,CRule)), vcount_Syn_Production :: (Int) } +{-# INLINABLE wrap_Production #-} +wrap_Production :: T_Production -> Inh_Production -> (Syn_Production ) +wrap_Production (T_Production act) (Inh_Production _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg25 = T_Production_vIn25 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount + (T_Production_vOut25 _lhsOadditionalDep _lhsOaroundDep _lhsOcProduction _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount) <- return (inv_Production_s26 sem arg25) + return (Syn_Production _lhsOadditionalDep _lhsOaroundDep _lhsOcProduction _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount) + ) + +-- cata +{-# INLINE sem_Production #-} +sem_Production :: Production -> T_Production +sem_Production ( Production con_ params_ constraints_ children_ rules_ typeSigs_ macro_ ) = sem_Production_Production con_ params_ constraints_ ( sem_Children children_ ) ( sem_Rules rules_ ) ( sem_TypeSigs typeSigs_ ) macro_ + +-- semantic domain +newtype T_Production = T_Production { + attach_T_Production :: Identity (T_Production_s26 ) + } +newtype T_Production_s26 = C_Production_s26 { + inv_Production_s26 :: (T_Production_v25 ) + } +data T_Production_s27 = C_Production_s27 +type T_Production_v25 = (T_Production_vIn25 ) -> (T_Production_vOut25 ) +data T_Production_vIn25 = T_Production_vIn25 ([Identifier]) (Map ConstructorIdent (Map Identifier [Expression])) (CVisitsMap) (Attributes) (Map Identifier Attributes) (AttrOrderMap) (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) (Identifier) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (String) (Attributes) (Map Identifier Attributes) (Int) +data T_Production_vOut25 = T_Production_vOut25 (Seq Edge) (Seq Edge) (CProduction) ([ConstructorIdent]) (Seq Edge) (Seq Error) (Seq Edge) (Seq Edge) (Mirage.Production) (Int) (Int) (Seq (Vertex,CRule)) (Int) +{-# NOINLINE sem_Production_Production #-} +sem_Production_Production :: (ConstructorIdent) -> ([Identifier]) -> ([Type]) -> T_Children -> T_Rules -> T_TypeSigs -> (MaybeMacro) -> T_Production +sem_Production_Production arg_con_ _ _ arg_children_ arg_rules_ arg_typeSigs_ _ = T_Production (return st26) where + {-# NOINLINE st26 #-} + st26 = let + v25 :: T_Production_v25 + v25 = \ (T_Production_vIn25 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) -> ( let + _childrenX5 = Control.Monad.Identity.runIdentity (attach_T_Children (arg_children_)) + _rulesX35 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_rules_)) + _typeSigsX41 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_typeSigs_)) + (T_Children_vOut4 _childrenIattributes _childrenIcollectChildrenInhs _childrenIcollectChildrenSyns _childrenIerrors _childrenIfields _childrenIgathAltAttrs _childrenIgathRules _childrenIinhs _childrenImirages _childrenInts _childrenIsinglevisits _childrenIterminals) = inv_Children_s5 _childrenX5 (T_Children_vIn4 _childrenOallfields _childrenOallnts _childrenOattrs _childrenOcon _childrenOinh _childrenOinhMap _childrenOmergeMap _childrenOnt _childrenOo_unbox _childrenOsyn _childrenOsynMap) + (T_Rules_vOut34 _rulesIdirectDep _rulesIerrors _rulesIgathAltAttrs _rulesIgathRules _rulesIinstDep _rulesIinstVars _rulesIlocVars _rulesImirages _rulesInAutoRules _rulesInExplicitRules) = inv_Rules_s35 _rulesX35 (T_Rules_vIn34 _rulesOallTypeSigs _rulesOallfields _rulesOallnts _rulesOaltAttrs _rulesOattrs _rulesOchildInhs _rulesOchildNts _rulesOcon _rulesOinh _rulesOinhsOfChildren _rulesOmergeMap _rulesOnt _rulesOo_case _rulesOo_cata _rulesOo_dovisit _rulesOo_newtypes _rulesOo_rename _rulesOo_sem _rulesOo_sig _rulesOo_wantvisit _rulesOoptions _rulesOprefix _rulesOsyn _rulesOsynsOfChildren) + (T_TypeSigs_vOut40 _typeSigsItypeSigs) = inv_TypeSigs_s41 _typeSigsX41 (T_TypeSigs_vIn40 _typeSigsOtypeSigs) + _childrenOcon = rule343 arg_con_ + _rulesOcon = rule344 arg_con_ + _gathAltAttrs = rule345 _childrenIgathAltAttrs _lhsIinh _rulesIgathAltAttrs + _altAttrs = rule346 _gathAltAttrs _lhsIvcount + _rulesOchildNts = rule347 _childrenInts + _rulesOchildInhs = rule348 _childrenIinhs + _inhRules = rule349 _lhsIinh _lhsInt arg_con_ + _gathRules = rule350 _childrenIgathRules _inhRules _rulesIgathRules + _lhsOrules :: Seq (Vertex,CRule) + _lhsOrules = rule351 _gathRules _lhsIvcount + _lhsOvcount :: Int + _lhsOvcount = rule352 _gathRules _lhsIvcount + _manualDeps = rule353 _lhsImanualAttrDepMap _lhsInt arg_con_ + _lhsOadditionalDep :: Seq Edge + _lhsOadditionalDep = rule354 _altAttrs _manualDeps + _rulesOsynsOfChildren = rule355 _childrenIcollectChildrenSyns + _rulesOinhsOfChildren = rule356 _childrenIcollectChildrenInhs + _mergeMap = rule357 _lhsImergeMap arg_con_ + _lhsOmergeDep :: Seq Edge + _lhsOmergeDep = rule358 _mergeDep1 _mergeDep2 + _mergeDep1 = rule359 _altAttrs _childrenIcollectChildrenSyns _mergeMap + _mergeDep2 = rule360 _altAttrs _childrenIcollectChildrenSyns _mergeMap + _aroundMap = rule361 _lhsIaroundMap arg_con_ + _aroundDep1 = rule362 _altAttrs _aroundMap _childrenIcollectChildrenSyns + _aroundDep2 = rule363 _altAttrs _aroundMap _childrenIcollectChildrenInhs + _lhsOaroundDep :: Seq Edge + _lhsOaroundDep = rule364 _aroundDep1 _aroundDep2 + _lhsOcons :: [ConstructorIdent] + _lhsOcons = rule365 arg_con_ + _typeSigsOtypeSigs = rule366 () + _rulesOallTypeSigs = rule367 _typeSigsItypeSigs + _cVisits = rule368 _childrenIsinglevisits _gathRules _lhsIcVisitsMap _lhsIinh _lhsInt _lhsIo_dovisit _lhsIsyn arg_con_ + _lhsOcProduction :: CProduction + _lhsOcProduction = rule369 _cVisits _childrenIfields _childrenIterminals arg_con_ + _allfields = rule370 _childrenIfields + _attrs = rule371 _childrenIattributes _inhnames _rulesIinstVars _rulesIlocVars + _inhnames = rule372 _lhsIinh + _synnames = rule373 _lhsIsyn + _lhsOmirage :: Mirage.Production + _lhsOmirage = rule374 _childrenImirages _rulesImirages arg_con_ + _lhsOdirectDep :: Seq Edge + _lhsOdirectDep = rule375 _rulesIdirectDep + _lhsOerrors :: Seq Error + _lhsOerrors = rule376 _childrenIerrors _rulesIerrors + _lhsOinstDep :: Seq Edge + _lhsOinstDep = rule377 _rulesIinstDep + _lhsOnAutoRules :: Int + _lhsOnAutoRules = rule378 _rulesInAutoRules + _lhsOnExplicitRules :: Int + _lhsOnExplicitRules = rule379 _rulesInExplicitRules + _childrenOallfields = rule380 _allfields + _childrenOallnts = rule381 _lhsIallnts + _childrenOattrs = rule382 _attrs + _childrenOinh = rule383 _lhsIinh + _childrenOinhMap = rule384 _lhsIinhMap + _childrenOmergeMap = rule385 _mergeMap + _childrenOnt = rule386 _lhsInt + _childrenOo_unbox = rule387 _lhsIo_unbox + _childrenOsyn = rule388 _lhsIsyn + _childrenOsynMap = rule389 _lhsIsynMap + _rulesOallfields = rule390 _allfields + _rulesOallnts = rule391 _lhsIallnts + _rulesOaltAttrs = rule392 _altAttrs + _rulesOattrs = rule393 _attrs + _rulesOinh = rule394 _lhsIinh + _rulesOmergeMap = rule395 _mergeMap + _rulesOnt = rule396 _lhsInt + _rulesOo_case = rule397 _lhsIo_case + _rulesOo_cata = rule398 _lhsIo_cata + _rulesOo_dovisit = rule399 _lhsIo_dovisit + _rulesOo_newtypes = rule400 _lhsIo_newtypes + _rulesOo_rename = rule401 _lhsIo_rename + _rulesOo_sem = rule402 _lhsIo_sem + _rulesOo_sig = rule403 _lhsIo_sig + _rulesOo_wantvisit = rule404 _lhsIo_wantvisit + _rulesOoptions = rule405 _lhsIoptions + _rulesOprefix = rule406 _lhsIprefix + _rulesOsyn = rule407 _lhsIsyn + __result_ = T_Production_vOut25 _lhsOadditionalDep _lhsOaroundDep _lhsOcProduction _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount + in __result_ ) + in C_Production_s26 v25 + {-# INLINE rule343 #-} + {-# LINE 93 "src-ag/Order.ag" #-} + rule343 = \ con_ -> + {-# LINE 93 "src-ag/Order.ag" #-} + con_ + {-# LINE 2703 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule344 #-} + {-# LINE 95 "src-ag/Order.ag" #-} + rule344 = \ con_ -> + {-# LINE 95 "src-ag/Order.ag" #-} + con_ + {-# LINE 2709 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule345 #-} + {-# LINE 175 "src-ag/Order.ag" #-} + rule345 = \ ((_childrenIgathAltAttrs) :: [AltAttr]) ((_lhsIinh) :: Attributes) ((_rulesIgathAltAttrs) :: [AltAttr]) -> + {-# LINE 175 "src-ag/Order.ag" #-} + [ AltAttr _LHS inh True | inh <- Map.keys _lhsIinh ] + ++ _childrenIgathAltAttrs + ++ _rulesIgathAltAttrs + {-# LINE 2717 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule346 #-} + {-# LINE 191 "src-ag/Order.ag" #-} + rule346 = \ _gathAltAttrs ((_lhsIvcount) :: Int) -> + {-# LINE 191 "src-ag/Order.ag" #-} + Map.fromList (zip _gathAltAttrs [_lhsIvcount..]) + {-# LINE 2723 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule347 #-} + {-# LINE 204 "src-ag/Order.ag" #-} + rule347 = \ ((_childrenInts) :: Seq (Identifier,NontermIdent)) -> + {-# LINE 204 "src-ag/Order.ag" #-} + Map.fromList (toList _childrenInts) + {-# LINE 2729 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule348 #-} + {-# LINE 205 "src-ag/Order.ag" #-} + rule348 = \ ((_childrenIinhs) :: Seq (Identifier,Attributes)) -> + {-# LINE 205 "src-ag/Order.ag" #-} + Map.fromList (toList _childrenIinhs) + {-# LINE 2735 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule349 #-} + {-# LINE 211 "src-ag/Order.ag" #-} + rule349 = \ ((_lhsIinh) :: Attributes) ((_lhsInt) :: Identifier) con_ -> + {-# LINE 211 "src-ag/Order.ag" #-} + [ cRuleLhsInh inh _lhsInt con_ tp | (inh,tp) <- Map.assocs _lhsIinh ] + {-# LINE 2741 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule350 #-} + {-# LINE 212 "src-ag/Order.ag" #-} + rule350 = \ ((_childrenIgathRules) :: Seq CRule) _inhRules ((_rulesIgathRules) :: Seq CRule) -> + {-# LINE 212 "src-ag/Order.ag" #-} + _inhRules ++ toList (_childrenIgathRules Seq.>< _rulesIgathRules) + {-# LINE 2747 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule351 #-} + {-# LINE 264 "src-ag/Order.ag" #-} + rule351 = \ _gathRules ((_lhsIvcount) :: Int) -> + {-# LINE 264 "src-ag/Order.ag" #-} + Seq.fromList (zip [_lhsIvcount..] _gathRules) + {-# LINE 2753 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule352 #-} + {-# LINE 265 "src-ag/Order.ag" #-} + rule352 = \ _gathRules ((_lhsIvcount) :: Int) -> + {-# LINE 265 "src-ag/Order.ag" #-} + _lhsIvcount + length _gathRules + {-# LINE 2759 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule353 #-} + {-# LINE 293 "src-ag/Order.ag" #-} + rule353 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) ((_lhsInt) :: Identifier) con_ -> + {-# LINE 293 "src-ag/Order.ag" #-} + Set.toList $ Map.findWithDefault Set.empty con_ $ Map.findWithDefault Map.empty _lhsInt _lhsImanualAttrDepMap + {-# LINE 2765 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule354 #-} + {-# LINE 296 "src-ag/Order.ag" #-} + rule354 = \ _altAttrs _manualDeps -> + {-# LINE 296 "src-ag/Order.ag" #-} + Seq.fromList [ (vertex True occA, vertex False occB) + | Dependency occA occB <- _manualDeps + , let vertex inout (OccAttr child nm) + | child == _LOC = findWithErr2 (AltAttr _LOC nm True) _altAttrs + | otherwise = findWithErr2 (AltAttr child nm inout) _altAttrs + vertex _ (OccRule nm) + = findWithErr2 (AltAttr _LOC (Ident ("_rule_" ++ show nm) (getPos nm)) True) _altAttrs + ] + {-# LINE 2778 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule355 #-} + {-# LINE 342 "src-ag/Order.ag" #-} + rule355 = \ ((_childrenIcollectChildrenSyns) :: Map Identifier Attributes ) -> + {-# LINE 342 "src-ag/Order.ag" #-} + _childrenIcollectChildrenSyns + {-# LINE 2784 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule356 #-} + {-# LINE 343 "src-ag/Order.ag" #-} + rule356 = \ ((_childrenIcollectChildrenInhs) :: Map Identifier Attributes ) -> + {-# LINE 343 "src-ag/Order.ag" #-} + _childrenIcollectChildrenInhs + {-# LINE 2790 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule357 #-} + {-# LINE 361 "src-ag/Order.ag" #-} + rule357 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) con_ -> + {-# LINE 361 "src-ag/Order.ag" #-} + Map.findWithDefault Map.empty con_ _lhsImergeMap + {-# LINE 2796 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule358 #-} + {-# LINE 372 "src-ag/Order.ag" #-} + rule358 = \ _mergeDep1 _mergeDep2 -> + {-# LINE 372 "src-ag/Order.ag" #-} + _mergeDep1 Seq.>< _mergeDep2 + {-# LINE 2802 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule359 #-} + {-# LINE 374 "src-ag/Order.ag" #-} + rule359 = \ _altAttrs ((_childrenIcollectChildrenSyns) :: Map Identifier Attributes ) _mergeMap -> + {-# LINE 374 "src-ag/Order.ag" #-} + Seq.fromList $ + [ (childVert, synVert) + | childNm <- Map.keys _mergeMap + , synNm <- Map.keys (findWithErr2 childNm _childrenIcollectChildrenSyns) + , let childNm' = Ident (show childNm ++ "_merge") (getPos childNm) + childAttr = AltAttr _LOC childNm' True + synAttr = AltAttr childNm synNm True + childVert = findWithErr2 childAttr _altAttrs + synVert = findWithErr2 synAttr _altAttrs + ] + {-# LINE 2817 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule360 #-} + {-# LINE 385 "src-ag/Order.ag" #-} + rule360 = \ _altAttrs ((_childrenIcollectChildrenSyns) :: Map Identifier Attributes ) _mergeMap -> + {-# LINE 385 "src-ag/Order.ag" #-} + Seq.fromList $ + [ (mergedVert, sourceVert) + | (childNm, (_,cs)) <- Map.assocs _mergeMap + , c <- cs + , synNm <- Map.keys (findWithErr2 childNm _childrenIcollectChildrenSyns) + , let sourceAttr = AltAttr childNm synNm True + mergedAttr = AltAttr c synNm True + sourceVert = findWithErr2 sourceAttr _altAttrs + mergedVert = findWithErr2 mergedAttr _altAttrs + ] + {-# LINE 2832 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule361 #-} + {-# LINE 414 "src-ag/Order.ag" #-} + rule361 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) con_ -> + {-# LINE 414 "src-ag/Order.ag" #-} + Map.findWithDefault Map.empty con_ _lhsIaroundMap + {-# LINE 2838 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule362 #-} + {-# LINE 422 "src-ag/Order.ag" #-} + rule362 = \ _altAttrs _aroundMap ((_childrenIcollectChildrenSyns) :: Map Identifier Attributes ) -> + {-# LINE 422 "src-ag/Order.ag" #-} + Seq.fromList $ + [ (childVert, synVert) + | childNm <- Map.keys _aroundMap + , synNm <- Map.keys (findWithErr2 childNm _childrenIcollectChildrenSyns) + , let childNm' = Ident (show childNm ++ "_around") (getPos childNm) + childAttr = AltAttr _LOC childNm' True + synAttr = AltAttr childNm synNm True + childVert = findWithErr2 childAttr _altAttrs + synVert = findWithErr2 synAttr _altAttrs + ] + {-# LINE 2853 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule363 #-} + {-# LINE 433 "src-ag/Order.ag" #-} + rule363 = \ _altAttrs _aroundMap ((_childrenIcollectChildrenInhs) :: Map Identifier Attributes ) -> + {-# LINE 433 "src-ag/Order.ag" #-} + Seq.fromList $ + [ (childVert, inhVert) + | childNm <- Map.keys _aroundMap + , inhNm <- Map.keys (findWithErr2 childNm _childrenIcollectChildrenInhs) + , let childNm' = Ident (show childNm ++ "_around") (getPos childNm) + childAttr = AltAttr _LOC childNm' True + inhAttr = AltAttr childNm inhNm False + childVert = findWithErr2 childAttr _altAttrs + inhVert = findWithErr2 inhAttr _altAttrs + ] + {-# LINE 2868 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule364 #-} + {-# LINE 443 "src-ag/Order.ag" #-} + rule364 = \ _aroundDep1 _aroundDep2 -> + {-# LINE 443 "src-ag/Order.ag" #-} + _aroundDep1 Seq.>< _aroundDep2 + {-# LINE 2874 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule365 #-} + {-# LINE 527 "src-ag/Order.ag" #-} + rule365 = \ con_ -> + {-# LINE 527 "src-ag/Order.ag" #-} + [con_] + {-# LINE 2880 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule366 #-} + {-# LINE 534 "src-ag/Order.ag" #-} + rule366 = \ (_ :: ()) -> + {-# LINE 534 "src-ag/Order.ag" #-} + Map.empty + {-# LINE 2886 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule367 #-} + {-# LINE 540 "src-ag/Order.ag" #-} + rule367 = \ ((_typeSigsItypeSigs) :: Map Identifier Type) -> + {-# LINE 540 "src-ag/Order.ag" #-} + _typeSigsItypeSigs + {-# LINE 2892 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule368 #-} + {-# LINE 608 "src-ag/Order.ag" #-} + rule368 = \ ((_childrenIsinglevisits) :: [CRule]) _gathRules ((_lhsIcVisitsMap) :: CVisitsMap) ((_lhsIinh) :: Attributes) ((_lhsInt) :: Identifier) ((_lhsIo_dovisit) :: Bool) ((_lhsIsyn) :: Attributes) con_ -> + {-# LINE 608 "src-ag/Order.ag" #-} + if _lhsIo_dovisit + then let prodsVisitsMap = findWithErr1 "Production.cVisits.nt" _lhsInt _lhsIcVisitsMap + visits = findWithErr1 "Production.cVisits.con" con_ prodsVisitsMap + in visits + else let vss = nubBy eqCRuleDefines _gathRules ++ _childrenIsinglevisits + in [CVisit _lhsIinh _lhsIsyn vss [] False] + {-# LINE 2903 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule369 #-} + {-# LINE 634 "src-ag/Order.ag" #-} + rule369 = \ _cVisits ((_childrenIfields) :: [(Identifier,Type,ChildKind)]) ((_childrenIterminals) :: [Identifier]) con_ -> + {-# LINE 634 "src-ag/Order.ag" #-} + CProduction con_ _cVisits _childrenIfields _childrenIterminals + {-# LINE 2909 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule370 #-} + {-# LINE 662 "src-ag/Order.ag" #-} + rule370 = \ ((_childrenIfields) :: [(Identifier,Type,ChildKind)]) -> + {-# LINE 662 "src-ag/Order.ag" #-} + _childrenIfields + {-# LINE 2915 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule371 #-} + {-# LINE 663 "src-ag/Order.ag" #-} + rule371 = \ ((_childrenIattributes) :: [(Identifier,Attributes,Attributes)]) _inhnames ((_rulesIinstVars) :: [Identifier]) ((_rulesIlocVars) :: [Identifier]) -> + {-# LINE 663 "src-ag/Order.ag" #-} + map ((,) _LOC) _rulesIlocVars ++ + map ((,) _INST) _rulesIinstVars ++ + map ((,) _LHS) _inhnames ++ + concat [map ((,) nm) (Map.keys as) | (nm,_,as) <- _childrenIattributes] + {-# LINE 2924 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule372 #-} + {-# LINE 667 "src-ag/Order.ag" #-} + rule372 = \ ((_lhsIinh) :: Attributes) -> + {-# LINE 667 "src-ag/Order.ag" #-} + Map.keys _lhsIinh + {-# LINE 2930 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule373 #-} + {-# LINE 668 "src-ag/Order.ag" #-} + rule373 = \ ((_lhsIsyn) :: Attributes) -> + {-# LINE 668 "src-ag/Order.ag" #-} + Map.keys _lhsIsyn + {-# LINE 2936 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule374 #-} + {-# LINE 43 "src-ag/TfmToMirage.ag" #-} + rule374 = \ ((_childrenImirages) :: [Mirage.Child]) ((_rulesImirages) :: [Mirage.Rule]) con_ -> + {-# LINE 43 "src-ag/TfmToMirage.ag" #-} + Mirage.Production (getName con_) _childrenImirages _rulesImirages + {-# LINE 2942 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule375 #-} + rule375 = \ ((_rulesIdirectDep) :: Seq Edge) -> + _rulesIdirectDep + {-# INLINE rule376 #-} + rule376 = \ ((_childrenIerrors) :: Seq Error) ((_rulesIerrors) :: Seq Error) -> + _childrenIerrors Seq.>< _rulesIerrors + {-# INLINE rule377 #-} + rule377 = \ ((_rulesIinstDep) :: Seq Edge) -> + _rulesIinstDep + {-# INLINE rule378 #-} + rule378 = \ ((_rulesInAutoRules) :: Int) -> + _rulesInAutoRules + {-# INLINE rule379 #-} + rule379 = \ ((_rulesInExplicitRules) :: Int) -> + _rulesInExplicitRules + {-# INLINE rule380 #-} + rule380 = \ _allfields -> + _allfields + {-# INLINE rule381 #-} + rule381 = \ ((_lhsIallnts) :: [Identifier]) -> + _lhsIallnts + {-# INLINE rule382 #-} + rule382 = \ _attrs -> + _attrs + {-# INLINE rule383 #-} + rule383 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule384 #-} + rule384 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> + _lhsIinhMap + {-# INLINE rule385 #-} + rule385 = \ _mergeMap -> + _mergeMap + {-# INLINE rule386 #-} + rule386 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule387 #-} + rule387 = \ ((_lhsIo_unbox) :: Bool) -> + _lhsIo_unbox + {-# INLINE rule388 #-} + rule388 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn + {-# INLINE rule389 #-} + rule389 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> + _lhsIsynMap + {-# INLINE rule390 #-} + rule390 = \ _allfields -> + _allfields + {-# INLINE rule391 #-} + rule391 = \ ((_lhsIallnts) :: [Identifier]) -> + _lhsIallnts + {-# INLINE rule392 #-} + rule392 = \ _altAttrs -> + _altAttrs + {-# INLINE rule393 #-} + rule393 = \ _attrs -> + _attrs + {-# INLINE rule394 #-} + rule394 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule395 #-} + rule395 = \ _mergeMap -> + _mergeMap + {-# INLINE rule396 #-} + rule396 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule397 #-} + rule397 = \ ((_lhsIo_case) :: Bool) -> + _lhsIo_case + {-# INLINE rule398 #-} + rule398 = \ ((_lhsIo_cata) :: Bool) -> + _lhsIo_cata + {-# INLINE rule399 #-} + rule399 = \ ((_lhsIo_dovisit) :: Bool) -> + _lhsIo_dovisit + {-# INLINE rule400 #-} + rule400 = \ ((_lhsIo_newtypes) :: Bool) -> + _lhsIo_newtypes + {-# INLINE rule401 #-} + rule401 = \ ((_lhsIo_rename) :: Bool) -> + _lhsIo_rename + {-# INLINE rule402 #-} + rule402 = \ ((_lhsIo_sem) :: Bool) -> + _lhsIo_sem + {-# INLINE rule403 #-} + rule403 = \ ((_lhsIo_sig) :: Bool) -> + _lhsIo_sig + {-# INLINE rule404 #-} + rule404 = \ ((_lhsIo_wantvisit) :: Bool) -> + _lhsIo_wantvisit + {-# INLINE rule405 #-} + rule405 = \ ((_lhsIoptions) :: Options) -> + _lhsIoptions + {-# INLINE rule406 #-} + rule406 = \ ((_lhsIprefix) :: String) -> + _lhsIprefix + {-# INLINE rule407 #-} + rule407 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn + +-- Productions ------------------------------------------------- +-- wrapper +data Inh_Productions = Inh_Productions { allnts_Inh_Productions :: ([Identifier]), aroundMap_Inh_Productions :: (Map ConstructorIdent (Map Identifier [Expression])), cVisitsMap_Inh_Productions :: (CVisitsMap), inh_Inh_Productions :: (Attributes), inhMap_Inh_Productions :: (Map Identifier Attributes), manualAttrDepMap_Inh_Productions :: (AttrOrderMap), mergeMap_Inh_Productions :: (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))), nt_Inh_Productions :: (Identifier), o_case_Inh_Productions :: (Bool), o_cata_Inh_Productions :: (Bool), o_dovisit_Inh_Productions :: (Bool), o_newtypes_Inh_Productions :: (Bool), o_rename_Inh_Productions :: (Bool), o_sem_Inh_Productions :: (Bool), o_sig_Inh_Productions :: (Bool), o_unbox_Inh_Productions :: (Bool), o_wantvisit_Inh_Productions :: (Bool), options_Inh_Productions :: (Options), prefix_Inh_Productions :: (String), syn_Inh_Productions :: (Attributes), synMap_Inh_Productions :: (Map Identifier Attributes), vcount_Inh_Productions :: (Int) } +data Syn_Productions = Syn_Productions { additionalDep_Syn_Productions :: (Seq Edge), aroundDep_Syn_Productions :: (Seq Edge), cProductions_Syn_Productions :: (CProductions), cons_Syn_Productions :: ([ConstructorIdent]), directDep_Syn_Productions :: (Seq Edge), errors_Syn_Productions :: (Seq Error), instDep_Syn_Productions :: (Seq Edge), mergeDep_Syn_Productions :: (Seq Edge), mirages_Syn_Productions :: ([Mirage.Production]), nAutoRules_Syn_Productions :: (Int), nExplicitRules_Syn_Productions :: (Int), rules_Syn_Productions :: (Seq (Vertex,CRule)), vcount_Syn_Productions :: (Int) } +{-# INLINABLE wrap_Productions #-} +wrap_Productions :: T_Productions -> Inh_Productions -> (Syn_Productions ) +wrap_Productions (T_Productions act) (Inh_Productions _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg28 = T_Productions_vIn28 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount + (T_Productions_vOut28 _lhsOadditionalDep _lhsOaroundDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount) <- return (inv_Productions_s29 sem arg28) + return (Syn_Productions _lhsOadditionalDep _lhsOaroundDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount) + ) + +-- cata +{-# NOINLINE sem_Productions #-} +sem_Productions :: Productions -> T_Productions +sem_Productions list = Prelude.foldr sem_Productions_Cons sem_Productions_Nil (Prelude.map sem_Production list) + +-- semantic domain +newtype T_Productions = T_Productions { + attach_T_Productions :: Identity (T_Productions_s29 ) + } +newtype T_Productions_s29 = C_Productions_s29 { + inv_Productions_s29 :: (T_Productions_v28 ) + } +data T_Productions_s30 = C_Productions_s30 +type T_Productions_v28 = (T_Productions_vIn28 ) -> (T_Productions_vOut28 ) +data T_Productions_vIn28 = T_Productions_vIn28 ([Identifier]) (Map ConstructorIdent (Map Identifier [Expression])) (CVisitsMap) (Attributes) (Map Identifier Attributes) (AttrOrderMap) (Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) (Identifier) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (String) (Attributes) (Map Identifier Attributes) (Int) +data T_Productions_vOut28 = T_Productions_vOut28 (Seq Edge) (Seq Edge) (CProductions) ([ConstructorIdent]) (Seq Edge) (Seq Error) (Seq Edge) (Seq Edge) ([Mirage.Production]) (Int) (Int) (Seq (Vertex,CRule)) (Int) +{-# NOINLINE sem_Productions_Cons #-} +sem_Productions_Cons :: T_Production -> T_Productions -> T_Productions +sem_Productions_Cons arg_hd_ arg_tl_ = T_Productions (return st29) where + {-# NOINLINE st29 #-} + st29 = let + v28 :: T_Productions_v28 + v28 = \ (T_Productions_vIn28 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) -> ( let + _hdX26 = Control.Monad.Identity.runIdentity (attach_T_Production (arg_hd_)) + _tlX29 = Control.Monad.Identity.runIdentity (attach_T_Productions (arg_tl_)) + (T_Production_vOut25 _hdIadditionalDep _hdIaroundDep _hdIcProduction _hdIcons _hdIdirectDep _hdIerrors _hdIinstDep _hdImergeDep _hdImirage _hdInAutoRules _hdInExplicitRules _hdIrules _hdIvcount) = inv_Production_s26 _hdX26 (T_Production_vIn25 _hdOallnts _hdOaroundMap _hdOcVisitsMap _hdOinh _hdOinhMap _hdOmanualAttrDepMap _hdOmergeMap _hdOnt _hdOo_case _hdOo_cata _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_unbox _hdOo_wantvisit _hdOoptions _hdOprefix _hdOsyn _hdOsynMap _hdOvcount) + (T_Productions_vOut28 _tlIadditionalDep _tlIaroundDep _tlIcProductions _tlIcons _tlIdirectDep _tlIerrors _tlIinstDep _tlImergeDep _tlImirages _tlInAutoRules _tlInExplicitRules _tlIrules _tlIvcount) = inv_Productions_s29 _tlX29 (T_Productions_vIn28 _tlOallnts _tlOaroundMap _tlOcVisitsMap _tlOinh _tlOinhMap _tlOmanualAttrDepMap _tlOmergeMap _tlOnt _tlOo_case _tlOo_cata _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_unbox _tlOo_wantvisit _tlOoptions _tlOprefix _tlOsyn _tlOsynMap _tlOvcount) + _lhsOcProductions :: CProductions + _lhsOcProductions = rule408 _hdIcProduction _tlIcProductions + _lhsOmirages :: [Mirage.Production] + _lhsOmirages = rule409 _hdImirage _tlImirages + _lhsOadditionalDep :: Seq Edge + _lhsOadditionalDep = rule410 _hdIadditionalDep _tlIadditionalDep + _lhsOaroundDep :: Seq Edge + _lhsOaroundDep = rule411 _hdIaroundDep _tlIaroundDep + _lhsOcons :: [ConstructorIdent] + _lhsOcons = rule412 _hdIcons _tlIcons + _lhsOdirectDep :: Seq Edge + _lhsOdirectDep = rule413 _hdIdirectDep _tlIdirectDep + _lhsOerrors :: Seq Error + _lhsOerrors = rule414 _hdIerrors _tlIerrors + _lhsOinstDep :: Seq Edge + _lhsOinstDep = rule415 _hdIinstDep _tlIinstDep + _lhsOmergeDep :: Seq Edge + _lhsOmergeDep = rule416 _hdImergeDep _tlImergeDep + _lhsOnAutoRules :: Int + _lhsOnAutoRules = rule417 _hdInAutoRules _tlInAutoRules + _lhsOnExplicitRules :: Int + _lhsOnExplicitRules = rule418 _hdInExplicitRules _tlInExplicitRules + _lhsOrules :: Seq (Vertex,CRule) + _lhsOrules = rule419 _hdIrules _tlIrules + _lhsOvcount :: Int + _lhsOvcount = rule420 _tlIvcount + _hdOallnts = rule421 _lhsIallnts + _hdOaroundMap = rule422 _lhsIaroundMap + _hdOcVisitsMap = rule423 _lhsIcVisitsMap + _hdOinh = rule424 _lhsIinh + _hdOinhMap = rule425 _lhsIinhMap + _hdOmanualAttrDepMap = rule426 _lhsImanualAttrDepMap + _hdOmergeMap = rule427 _lhsImergeMap + _hdOnt = rule428 _lhsInt + _hdOo_case = rule429 _lhsIo_case + _hdOo_cata = rule430 _lhsIo_cata + _hdOo_dovisit = rule431 _lhsIo_dovisit + _hdOo_newtypes = rule432 _lhsIo_newtypes + _hdOo_rename = rule433 _lhsIo_rename + _hdOo_sem = rule434 _lhsIo_sem + _hdOo_sig = rule435 _lhsIo_sig + _hdOo_unbox = rule436 _lhsIo_unbox + _hdOo_wantvisit = rule437 _lhsIo_wantvisit + _hdOoptions = rule438 _lhsIoptions + _hdOprefix = rule439 _lhsIprefix + _hdOsyn = rule440 _lhsIsyn + _hdOsynMap = rule441 _lhsIsynMap + _hdOvcount = rule442 _lhsIvcount + _tlOallnts = rule443 _lhsIallnts + _tlOaroundMap = rule444 _lhsIaroundMap + _tlOcVisitsMap = rule445 _lhsIcVisitsMap + _tlOinh = rule446 _lhsIinh + _tlOinhMap = rule447 _lhsIinhMap + _tlOmanualAttrDepMap = rule448 _lhsImanualAttrDepMap + _tlOmergeMap = rule449 _lhsImergeMap + _tlOnt = rule450 _lhsInt + _tlOo_case = rule451 _lhsIo_case + _tlOo_cata = rule452 _lhsIo_cata + _tlOo_dovisit = rule453 _lhsIo_dovisit + _tlOo_newtypes = rule454 _lhsIo_newtypes + _tlOo_rename = rule455 _lhsIo_rename + _tlOo_sem = rule456 _lhsIo_sem + _tlOo_sig = rule457 _lhsIo_sig + _tlOo_unbox = rule458 _lhsIo_unbox + _tlOo_wantvisit = rule459 _lhsIo_wantvisit + _tlOoptions = rule460 _lhsIoptions + _tlOprefix = rule461 _lhsIprefix + _tlOsyn = rule462 _lhsIsyn + _tlOsynMap = rule463 _lhsIsynMap + _tlOvcount = rule464 _hdIvcount + __result_ = T_Productions_vOut28 _lhsOadditionalDep _lhsOaroundDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount + in __result_ ) + in C_Productions_s29 v28 + {-# INLINE rule408 #-} + {-# LINE 631 "src-ag/Order.ag" #-} + rule408 = \ ((_hdIcProduction) :: CProduction) ((_tlIcProductions) :: CProductions) -> + {-# LINE 631 "src-ag/Order.ag" #-} + _hdIcProduction : _tlIcProductions + {-# LINE 3162 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule409 #-} + {-# LINE 38 "src-ag/TfmToMirage.ag" #-} + rule409 = \ ((_hdImirage) :: Mirage.Production) ((_tlImirages) :: [Mirage.Production]) -> + {-# LINE 38 "src-ag/TfmToMirage.ag" #-} + _hdImirage : _tlImirages + {-# LINE 3168 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule410 #-} + rule410 = \ ((_hdIadditionalDep) :: Seq Edge) ((_tlIadditionalDep) :: Seq Edge) -> + _hdIadditionalDep Seq.>< _tlIadditionalDep + {-# INLINE rule411 #-} + rule411 = \ ((_hdIaroundDep) :: Seq Edge) ((_tlIaroundDep) :: Seq Edge) -> + _hdIaroundDep Seq.>< _tlIaroundDep + {-# INLINE rule412 #-} + rule412 = \ ((_hdIcons) :: [ConstructorIdent]) ((_tlIcons) :: [ConstructorIdent]) -> + _hdIcons ++ _tlIcons + {-# INLINE rule413 #-} + rule413 = \ ((_hdIdirectDep) :: Seq Edge) ((_tlIdirectDep) :: Seq Edge) -> + _hdIdirectDep Seq.>< _tlIdirectDep + {-# INLINE rule414 #-} + rule414 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> + _hdIerrors Seq.>< _tlIerrors + {-# INLINE rule415 #-} + rule415 = \ ((_hdIinstDep) :: Seq Edge) ((_tlIinstDep) :: Seq Edge) -> + _hdIinstDep Seq.>< _tlIinstDep + {-# INLINE rule416 #-} + rule416 = \ ((_hdImergeDep) :: Seq Edge) ((_tlImergeDep) :: Seq Edge) -> + _hdImergeDep Seq.>< _tlImergeDep + {-# INLINE rule417 #-} + rule417 = \ ((_hdInAutoRules) :: Int) ((_tlInAutoRules) :: Int) -> + _hdInAutoRules + _tlInAutoRules + {-# INLINE rule418 #-} + rule418 = \ ((_hdInExplicitRules) :: Int) ((_tlInExplicitRules) :: Int) -> + _hdInExplicitRules + _tlInExplicitRules + {-# INLINE rule419 #-} + rule419 = \ ((_hdIrules) :: Seq (Vertex,CRule)) ((_tlIrules) :: Seq (Vertex,CRule)) -> + _hdIrules Seq.>< _tlIrules + {-# INLINE rule420 #-} + rule420 = \ ((_tlIvcount) :: Int) -> + _tlIvcount + {-# INLINE rule421 #-} + rule421 = \ ((_lhsIallnts) :: [Identifier]) -> + _lhsIallnts + {-# INLINE rule422 #-} + rule422 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) -> + _lhsIaroundMap + {-# INLINE rule423 #-} + rule423 = \ ((_lhsIcVisitsMap) :: CVisitsMap) -> + _lhsIcVisitsMap + {-# INLINE rule424 #-} + rule424 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule425 #-} + rule425 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> + _lhsIinhMap + {-# INLINE rule426 #-} + rule426 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) -> + _lhsImanualAttrDepMap + {-# INLINE rule427 #-} + rule427 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) -> + _lhsImergeMap + {-# INLINE rule428 #-} + rule428 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule429 #-} + rule429 = \ ((_lhsIo_case) :: Bool) -> + _lhsIo_case + {-# INLINE rule430 #-} + rule430 = \ ((_lhsIo_cata) :: Bool) -> + _lhsIo_cata + {-# INLINE rule431 #-} + rule431 = \ ((_lhsIo_dovisit) :: Bool) -> + _lhsIo_dovisit + {-# INLINE rule432 #-} + rule432 = \ ((_lhsIo_newtypes) :: Bool) -> + _lhsIo_newtypes + {-# INLINE rule433 #-} + rule433 = \ ((_lhsIo_rename) :: Bool) -> + _lhsIo_rename + {-# INLINE rule434 #-} + rule434 = \ ((_lhsIo_sem) :: Bool) -> + _lhsIo_sem + {-# INLINE rule435 #-} + rule435 = \ ((_lhsIo_sig) :: Bool) -> + _lhsIo_sig + {-# INLINE rule436 #-} + rule436 = \ ((_lhsIo_unbox) :: Bool) -> + _lhsIo_unbox + {-# INLINE rule437 #-} + rule437 = \ ((_lhsIo_wantvisit) :: Bool) -> + _lhsIo_wantvisit + {-# INLINE rule438 #-} + rule438 = \ ((_lhsIoptions) :: Options) -> + _lhsIoptions + {-# INLINE rule439 #-} + rule439 = \ ((_lhsIprefix) :: String) -> + _lhsIprefix + {-# INLINE rule440 #-} + rule440 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn + {-# INLINE rule441 #-} + rule441 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> + _lhsIsynMap + {-# INLINE rule442 #-} + rule442 = \ ((_lhsIvcount) :: Int) -> + _lhsIvcount + {-# INLINE rule443 #-} + rule443 = \ ((_lhsIallnts) :: [Identifier]) -> + _lhsIallnts + {-# INLINE rule444 #-} + rule444 = \ ((_lhsIaroundMap) :: Map ConstructorIdent (Map Identifier [Expression])) -> + _lhsIaroundMap + {-# INLINE rule445 #-} + rule445 = \ ((_lhsIcVisitsMap) :: CVisitsMap) -> + _lhsIcVisitsMap + {-# INLINE rule446 #-} + rule446 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule447 #-} + rule447 = \ ((_lhsIinhMap) :: Map Identifier Attributes) -> + _lhsIinhMap + {-# INLINE rule448 #-} + rule448 = \ ((_lhsImanualAttrDepMap) :: AttrOrderMap) -> + _lhsImanualAttrDepMap + {-# INLINE rule449 #-} + rule449 = \ ((_lhsImergeMap) :: Map ConstructorIdent (Map Identifier (Identifier,[Identifier]))) -> + _lhsImergeMap + {-# INLINE rule450 #-} + rule450 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule451 #-} + rule451 = \ ((_lhsIo_case) :: Bool) -> + _lhsIo_case + {-# INLINE rule452 #-} + rule452 = \ ((_lhsIo_cata) :: Bool) -> + _lhsIo_cata + {-# INLINE rule453 #-} + rule453 = \ ((_lhsIo_dovisit) :: Bool) -> + _lhsIo_dovisit + {-# INLINE rule454 #-} + rule454 = \ ((_lhsIo_newtypes) :: Bool) -> + _lhsIo_newtypes + {-# INLINE rule455 #-} + rule455 = \ ((_lhsIo_rename) :: Bool) -> + _lhsIo_rename + {-# INLINE rule456 #-} + rule456 = \ ((_lhsIo_sem) :: Bool) -> + _lhsIo_sem + {-# INLINE rule457 #-} + rule457 = \ ((_lhsIo_sig) :: Bool) -> + _lhsIo_sig + {-# INLINE rule458 #-} + rule458 = \ ((_lhsIo_unbox) :: Bool) -> + _lhsIo_unbox + {-# INLINE rule459 #-} + rule459 = \ ((_lhsIo_wantvisit) :: Bool) -> + _lhsIo_wantvisit + {-# INLINE rule460 #-} + rule460 = \ ((_lhsIoptions) :: Options) -> + _lhsIoptions + {-# INLINE rule461 #-} + rule461 = \ ((_lhsIprefix) :: String) -> + _lhsIprefix + {-# INLINE rule462 #-} + rule462 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn + {-# INLINE rule463 #-} + rule463 = \ ((_lhsIsynMap) :: Map Identifier Attributes) -> + _lhsIsynMap + {-# INLINE rule464 #-} + rule464 = \ ((_hdIvcount) :: Int) -> + _hdIvcount +{-# NOINLINE sem_Productions_Nil #-} +sem_Productions_Nil :: T_Productions +sem_Productions_Nil = T_Productions (return st29) where + {-# NOINLINE st29 #-} + st29 = let + v28 :: T_Productions_v28 + v28 = \ (T_Productions_vIn28 _lhsIallnts _lhsIaroundMap _lhsIcVisitsMap _lhsIinh _lhsIinhMap _lhsImanualAttrDepMap _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_unbox _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynMap _lhsIvcount) -> ( let + _lhsOcProductions :: CProductions + _lhsOcProductions = rule465 () + _lhsOmirages :: [Mirage.Production] + _lhsOmirages = rule466 () + _lhsOadditionalDep :: Seq Edge + _lhsOadditionalDep = rule467 () + _lhsOaroundDep :: Seq Edge + _lhsOaroundDep = rule468 () + _lhsOcons :: [ConstructorIdent] + _lhsOcons = rule469 () + _lhsOdirectDep :: Seq Edge + _lhsOdirectDep = rule470 () + _lhsOerrors :: Seq Error + _lhsOerrors = rule471 () + _lhsOinstDep :: Seq Edge + _lhsOinstDep = rule472 () + _lhsOmergeDep :: Seq Edge + _lhsOmergeDep = rule473 () + _lhsOnAutoRules :: Int + _lhsOnAutoRules = rule474 () + _lhsOnExplicitRules :: Int + _lhsOnExplicitRules = rule475 () + _lhsOrules :: Seq (Vertex,CRule) + _lhsOrules = rule476 () + _lhsOvcount :: Int + _lhsOvcount = rule477 _lhsIvcount + __result_ = T_Productions_vOut28 _lhsOadditionalDep _lhsOaroundDep _lhsOcProductions _lhsOcons _lhsOdirectDep _lhsOerrors _lhsOinstDep _lhsOmergeDep _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules _lhsOrules _lhsOvcount + in __result_ ) + in C_Productions_s29 v28 + {-# INLINE rule465 #-} + {-# LINE 632 "src-ag/Order.ag" #-} + rule465 = \ (_ :: ()) -> + {-# LINE 632 "src-ag/Order.ag" #-} + [] + {-# LINE 3375 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule466 #-} + {-# LINE 39 "src-ag/TfmToMirage.ag" #-} + rule466 = \ (_ :: ()) -> + {-# LINE 39 "src-ag/TfmToMirage.ag" #-} + [] + {-# LINE 3381 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule467 #-} + rule467 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule468 #-} + rule468 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule469 #-} + rule469 = \ (_ :: ()) -> + [] + {-# INLINE rule470 #-} + rule470 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule471 #-} + rule471 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule472 #-} + rule472 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule473 #-} + rule473 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule474 #-} + rule474 = \ (_ :: ()) -> + 0 + {-# INLINE rule475 #-} + rule475 = \ (_ :: ()) -> + 0 + {-# INLINE rule476 #-} + rule476 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule477 #-} + rule477 = \ ((_lhsIvcount) :: Int) -> + _lhsIvcount + +-- Rule -------------------------------------------------------- +-- wrapper +data Inh_Rule = Inh_Rule { allTypeSigs_Inh_Rule :: (Map Identifier Type), allfields_Inh_Rule :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Rule :: ([Identifier]), altAttrs_Inh_Rule :: (Map AltAttr Vertex), attrs_Inh_Rule :: ([(Identifier,Identifier)]), childInhs_Inh_Rule :: (Map Identifier Attributes), childNts_Inh_Rule :: (Map Identifier NontermIdent), con_Inh_Rule :: (Identifier), inh_Inh_Rule :: (Attributes), inhsOfChildren_Inh_Rule :: (Map Identifier Attributes), mergeMap_Inh_Rule :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Rule :: (Identifier), o_case_Inh_Rule :: (Bool), o_cata_Inh_Rule :: (Bool), o_dovisit_Inh_Rule :: (Bool), o_newtypes_Inh_Rule :: (Bool), o_rename_Inh_Rule :: (Bool), o_sem_Inh_Rule :: (Bool), o_sig_Inh_Rule :: (Bool), o_wantvisit_Inh_Rule :: (Bool), options_Inh_Rule :: (Options), prefix_Inh_Rule :: (String), syn_Inh_Rule :: (Attributes), synsOfChildren_Inh_Rule :: (Map Identifier Attributes) } +data Syn_Rule = Syn_Rule { directDep_Syn_Rule :: (Seq Edge), errors_Syn_Rule :: (Seq Error), gathAltAttrs_Syn_Rule :: ([AltAttr]), gathRules_Syn_Rule :: (Seq CRule), instDep_Syn_Rule :: (Seq Edge), instVars_Syn_Rule :: ([Identifier]), locVars_Syn_Rule :: ([Identifier]), mirage_Syn_Rule :: (Mirage.Rule), nAutoRules_Syn_Rule :: (Int), nExplicitRules_Syn_Rule :: (Int) } +{-# INLINABLE wrap_Rule #-} +wrap_Rule :: T_Rule -> Inh_Rule -> (Syn_Rule ) +wrap_Rule (T_Rule act) (Inh_Rule _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg31 = T_Rule_vIn31 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren + (T_Rule_vOut31 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules) <- return (inv_Rule_s32 sem arg31) + return (Syn_Rule _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules) + ) + +-- cata +{-# INLINE sem_Rule #-} +sem_Rule :: Rule -> T_Rule +sem_Rule ( Rule mbName_ pattern_ rhs_ owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ ) = sem_Rule_Rule mbName_ ( sem_Pattern pattern_ ) ( sem_Expression rhs_ ) owrt_ origin_ explicit_ pure_ identity_ mbError_ eager_ + +-- semantic domain +newtype T_Rule = T_Rule { + attach_T_Rule :: Identity (T_Rule_s32 ) + } +newtype T_Rule_s32 = C_Rule_s32 { + inv_Rule_s32 :: (T_Rule_v31 ) + } +data T_Rule_s33 = C_Rule_s33 +type T_Rule_v31 = (T_Rule_vIn31 ) -> (T_Rule_vOut31 ) +data T_Rule_vIn31 = T_Rule_vIn31 (Map Identifier Type) ([(Identifier,Type,ChildKind)]) ([Identifier]) (Map AltAttr Vertex) ([(Identifier,Identifier)]) (Map Identifier Attributes) (Map Identifier NontermIdent) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (String) (Attributes) (Map Identifier Attributes) +data T_Rule_vOut31 = T_Rule_vOut31 (Seq Edge) (Seq Error) ([AltAttr]) (Seq CRule) (Seq Edge) ([Identifier]) ([Identifier]) (Mirage.Rule) (Int) (Int) +{-# NOINLINE sem_Rule_Rule #-} +sem_Rule_Rule :: (Maybe Identifier) -> T_Pattern -> T_Expression -> (Bool) -> (String) -> (Bool) -> (Bool) -> (Bool) -> (Maybe Error) -> (Bool) -> T_Rule +sem_Rule_Rule arg_mbName_ arg_pattern_ arg_rhs_ arg_owrt_ arg_origin_ arg_explicit_ _ _ _ _ = T_Rule (return st32) where + {-# NOINLINE st32 #-} + st32 = let + v31 :: T_Rule_v31 + v31 = \ (T_Rule_vIn31 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) -> ( let + _patternX20 = Control.Monad.Identity.runIdentity (attach_T_Pattern (arg_pattern_)) + _rhsX8 = Control.Monad.Identity.runIdentity (attach_T_Expression (arg_rhs_)) + (T_Pattern_vOut19 _patternIcopy _patternIerrors _patternIgathAltAttrs _patternIinstVars _patternIisUnderscore _patternIlocVars _patternIpatternAttrs _patternIpp) = inv_Pattern_s20 _patternX20 (T_Pattern_vIn19 _patternOallTypeSigs _patternOaltAttrs _patternObelowIrrefutable _patternOcon _patternOinh _patternOnt _patternOsyn) + (T_Expression_vOut7 _rhsIallRhsVars _rhsIcopy _rhsIerrors _rhsIlns _rhsItextLines _rhsIusedAttrs _rhsIusedFields _rhsIusedLocals) = inv_Expression_s8 _rhsX8 (T_Expression_vIn7 _rhsOallfields _rhsOallnts _rhsOattrs _rhsOcon _rhsOmergeMap _rhsOnt _rhsOoptions) + _lhsOnExplicitRules :: Int + _lhsOnExplicitRules = rule478 arg_explicit_ + _lhsOnAutoRules :: Int + _lhsOnAutoRules = rule479 arg_origin_ + _defines = rule480 _lhsIallTypeSigs _lhsIaltAttrs _lhsIchildInhs _lhsIsyn _patternIpatternAttrs + _gathRules = rule481 _defines _lhsIchildNts _lhsIcon _lhsInt _patternIcopy _rhsIallRhsVars _rhsItextLines arg_explicit_ arg_mbName_ arg_origin_ arg_owrt_ + _lhsOdirectDep :: Seq Edge + _lhsOdirectDep = rule482 _defines _lhsIaltAttrs _rhsIusedAttrs _rhsIusedFields _rhsIusedLocals + _instDep1 = rule483 _defines _lhsIaltAttrs _lhsIsynsOfChildren + _instDep2 = rule484 _defines _lhsIaltAttrs _lhsIinhsOfChildren + _lhsOinstDep :: Seq Edge + _lhsOinstDep = rule485 _instDep1 _instDep2 + _lhsOmirage :: Mirage.Rule + _lhsOmirage = rule486 _patternIpatternAttrs _patternIpp _rhsIlns _rhsIusedAttrs _rhsIusedFields _rhsIusedLocals arg_explicit_ arg_origin_ + _patternObelowIrrefutable = rule487 () + _lhsOerrors :: Seq Error + _lhsOerrors = rule488 _patternIerrors _rhsIerrors + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule489 _patternIgathAltAttrs + _lhsOgathRules :: Seq CRule + _lhsOgathRules = rule490 _gathRules + _lhsOinstVars :: [Identifier] + _lhsOinstVars = rule491 _patternIinstVars + _lhsOlocVars :: [Identifier] + _lhsOlocVars = rule492 _patternIlocVars + _patternOallTypeSigs = rule493 _lhsIallTypeSigs + _patternOaltAttrs = rule494 _lhsIaltAttrs + _patternOcon = rule495 _lhsIcon + _patternOinh = rule496 _lhsIinh + _patternOnt = rule497 _lhsInt + _patternOsyn = rule498 _lhsIsyn + _rhsOallfields = rule499 _lhsIallfields + _rhsOallnts = rule500 _lhsIallnts + _rhsOattrs = rule501 _lhsIattrs + _rhsOcon = rule502 _lhsIcon + _rhsOmergeMap = rule503 _lhsImergeMap + _rhsOnt = rule504 _lhsInt + _rhsOoptions = rule505 _lhsIoptions + __result_ = T_Rule_vOut31 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirage _lhsOnAutoRules _lhsOnExplicitRules + in __result_ ) + in C_Rule_s32 v31 + {-# INLINE rule478 #-} + {-# LINE 64 "src-ag/Order.ag" #-} + rule478 = \ explicit_ -> + {-# LINE 64 "src-ag/Order.ag" #-} + if explicit_ + then 1 + else 0 + {-# LINE 3505 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule479 #-} + {-# LINE 67 "src-ag/Order.ag" #-} + rule479 = \ origin_ -> + {-# LINE 67 "src-ag/Order.ag" #-} + if startsWith "use rule" origin_ || startsWith "copy rule" origin_ + then 1 + else 0 + {-# LINE 3513 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule480 #-} + {-# LINE 220 "src-ag/Order.ag" #-} + rule480 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) ((_lhsIaltAttrs) :: Map AltAttr Vertex) ((_lhsIchildInhs) :: Map Identifier Attributes) ((_lhsIsyn) :: Attributes) ((_patternIpatternAttrs) :: [(Identifier,Identifier,Bool)]) -> + {-# LINE 220 "src-ag/Order.ag" #-} + let tp field attr | field == _LOC || field == _INST + = Map.lookup attr _lhsIallTypeSigs + | field == _LHS = Map.lookup attr _lhsIsyn + | otherwise = Map.lookup attr (findWithErr1 "Rule.defines.tp" field _lhsIchildInhs) + typ :: Pattern -> Maybe Type + typ (Alias field attr _) = tp field attr + typ (Underscore _) = Nothing + typ _ = Nothing + in Map.fromList [ (findWithErr1 "Rule.defines" aa _lhsIaltAttrs, (field,attr,(tp field attr))) + | (field,attr,isLocalOrInst) <- _patternIpatternAttrs + , let aa = AltAttr field attr isLocalOrInst + ] + {-# LINE 3530 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule481 #-} + {-# LINE 234 "src-ag/Order.ag" #-} + rule481 = \ _defines ((_lhsIchildNts) :: Map Identifier NontermIdent) ((_lhsIcon) :: Identifier) ((_lhsInt) :: Identifier) ((_patternIcopy) :: Pattern) ((_rhsIallRhsVars) :: Set (Identifier,Identifier)) ((_rhsItextLines) :: [String]) explicit_ mbName_ origin_ owrt_ -> + {-# LINE 234 "src-ag/Order.ag" #-} + let childnt field = Map.lookup field _lhsIchildNts + in Seq.fromList [ CRule attr False True _lhsInt _lhsIcon field (childnt field) tp _patternIcopy _rhsItextLines _defines owrt_ origin_ _rhsIallRhsVars explicit_ mbName_ + | (field,attr,tp) <- Map.elems _defines + ] + {-# LINE 3539 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule482 #-} + {-# LINE 273 "src-ag/Order.ag" #-} + rule482 = \ _defines ((_lhsIaltAttrs) :: Map AltAttr Vertex) ((_rhsIusedAttrs) :: [(Identifier,Identifier)]) ((_rhsIusedFields) :: [Identifier]) ((_rhsIusedLocals) :: [Identifier]) -> + {-# LINE 273 "src-ag/Order.ag" #-} + let defined = Map.keys _defines + used = [ Map.lookup (AltAttr field attr True) _lhsIaltAttrs | (field,attr) <- _rhsIusedAttrs] + ++ [ Map.lookup (AltAttr _LOC attr True) _lhsIaltAttrs | attr <- _rhsIusedLocals ++ _rhsIusedFields ] + in Seq.fromList [ (x,y) | Just x <- used, y <- defined ] + {-# LINE 3548 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule483 #-} + {-# LINE 317 "src-ag/Order.ag" #-} + rule483 = \ _defines ((_lhsIaltAttrs) :: Map AltAttr Vertex) ((_lhsIsynsOfChildren) :: Map Identifier Attributes) -> + {-# LINE 317 "src-ag/Order.ag" #-} + Seq.fromList $ + [ (instVert, synVert) + | (field,instNm,_) <- Map.elems _defines + , field == _INST + , synNm <- Map.keys (findWithErr2 instNm _lhsIsynsOfChildren) + , let instAttr = AltAttr _INST instNm True + synAttr = AltAttr instNm synNm True + instVert = findWithErr2 instAttr _lhsIaltAttrs + synVert = findWithErr2 synAttr _lhsIaltAttrs + ] + {-# LINE 3563 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule484 #-} + {-# LINE 328 "src-ag/Order.ag" #-} + rule484 = \ _defines ((_lhsIaltAttrs) :: Map AltAttr Vertex) ((_lhsIinhsOfChildren) :: Map Identifier Attributes) -> + {-# LINE 328 "src-ag/Order.ag" #-} + Seq.fromList $ + [ (instVert, inhVert) + | (field,instNm,_) <- Map.elems _defines + , field == _INST + , inhNm <- Map.keys (findWithErr2 instNm _lhsIinhsOfChildren) + , let instAttr = AltAttr _INST instNm True + inhAttr = AltAttr instNm inhNm False + instVert = findWithErr2 instAttr _lhsIaltAttrs + inhVert = findWithErr2 inhAttr _lhsIaltAttrs + ] + {-# LINE 3578 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule485 #-} + {-# LINE 338 "src-ag/Order.ag" #-} + rule485 = \ _instDep1 _instDep2 -> + {-# LINE 338 "src-ag/Order.ag" #-} + _instDep1 Seq.>< _instDep2 + {-# LINE 3584 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule486 #-} + {-# LINE 60 "src-ag/TfmToMirage.ag" #-} + rule486 = \ ((_patternIpatternAttrs) :: [(Identifier,Identifier,Bool)]) ((_patternIpp) :: PP_Doc) ((_rhsIlns) :: [String]) ((_rhsIusedAttrs) :: [(Identifier,Identifier)]) ((_rhsIusedFields) :: [Identifier]) ((_rhsIusedLocals) :: [Identifier]) explicit_ origin_ -> + {-# LINE 60 "src-ag/TfmToMirage.ag" #-} + Mirage.Rule + [Mirage.Address (getName field) (getName attr) | (field,attr,_) <- _patternIpatternAttrs] + ([Mirage.Address (getName field) (getName attr) | (field,attr) <- _rhsIusedAttrs] + ++ [ Mirage.Address (getName _LOC) (getName attr) | attr <- _rhsIusedLocals ++ _rhsIusedFields]) + explicit_ + origin_ + (disp (_patternIpp >-< indent 1 (text "= " >|< vlist _rhsIlns)) 0 "") + {-# LINE 3596 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule487 #-} + {-# LINE 98 "src-ag/TfmToMirage.ag" #-} + rule487 = \ (_ :: ()) -> + {-# LINE 98 "src-ag/TfmToMirage.ag" #-} + False + {-# LINE 3602 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule488 #-} + rule488 = \ ((_patternIerrors) :: Seq Error) ((_rhsIerrors) :: Seq Error) -> + _patternIerrors Seq.>< _rhsIerrors + {-# INLINE rule489 #-} + rule489 = \ ((_patternIgathAltAttrs) :: [AltAttr]) -> + _patternIgathAltAttrs + {-# INLINE rule490 #-} + rule490 = \ _gathRules -> + _gathRules + {-# INLINE rule491 #-} + rule491 = \ ((_patternIinstVars) :: [Identifier]) -> + _patternIinstVars + {-# INLINE rule492 #-} + rule492 = \ ((_patternIlocVars) :: [Identifier]) -> + _patternIlocVars + {-# INLINE rule493 #-} + rule493 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> + _lhsIallTypeSigs + {-# INLINE rule494 #-} + rule494 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> + _lhsIaltAttrs + {-# INLINE rule495 #-} + rule495 = \ ((_lhsIcon) :: Identifier) -> + _lhsIcon + {-# INLINE rule496 #-} + rule496 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule497 #-} + rule497 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule498 #-} + rule498 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn + {-# INLINE rule499 #-} + rule499 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> + _lhsIallfields + {-# INLINE rule500 #-} + rule500 = \ ((_lhsIallnts) :: [Identifier]) -> + _lhsIallnts + {-# INLINE rule501 #-} + rule501 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> + _lhsIattrs + {-# INLINE rule502 #-} + rule502 = \ ((_lhsIcon) :: Identifier) -> + _lhsIcon + {-# INLINE rule503 #-} + rule503 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> + _lhsImergeMap + {-# INLINE rule504 #-} + rule504 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule505 #-} + rule505 = \ ((_lhsIoptions) :: Options) -> + _lhsIoptions + +-- Rules ------------------------------------------------------- +-- wrapper +data Inh_Rules = Inh_Rules { allTypeSigs_Inh_Rules :: (Map Identifier Type), allfields_Inh_Rules :: ([(Identifier,Type,ChildKind)]), allnts_Inh_Rules :: ([Identifier]), altAttrs_Inh_Rules :: (Map AltAttr Vertex), attrs_Inh_Rules :: ([(Identifier,Identifier)]), childInhs_Inh_Rules :: (Map Identifier Attributes), childNts_Inh_Rules :: (Map Identifier NontermIdent), con_Inh_Rules :: (Identifier), inh_Inh_Rules :: (Attributes), inhsOfChildren_Inh_Rules :: (Map Identifier Attributes), mergeMap_Inh_Rules :: (Map Identifier (Identifier,[Identifier])), nt_Inh_Rules :: (Identifier), o_case_Inh_Rules :: (Bool), o_cata_Inh_Rules :: (Bool), o_dovisit_Inh_Rules :: (Bool), o_newtypes_Inh_Rules :: (Bool), o_rename_Inh_Rules :: (Bool), o_sem_Inh_Rules :: (Bool), o_sig_Inh_Rules :: (Bool), o_wantvisit_Inh_Rules :: (Bool), options_Inh_Rules :: (Options), prefix_Inh_Rules :: (String), syn_Inh_Rules :: (Attributes), synsOfChildren_Inh_Rules :: (Map Identifier Attributes) } +data Syn_Rules = Syn_Rules { directDep_Syn_Rules :: (Seq Edge), errors_Syn_Rules :: (Seq Error), gathAltAttrs_Syn_Rules :: ([AltAttr]), gathRules_Syn_Rules :: (Seq CRule), instDep_Syn_Rules :: (Seq Edge), instVars_Syn_Rules :: ([Identifier]), locVars_Syn_Rules :: ([Identifier]), mirages_Syn_Rules :: ([Mirage.Rule]), nAutoRules_Syn_Rules :: (Int), nExplicitRules_Syn_Rules :: (Int) } +{-# INLINABLE wrap_Rules #-} +wrap_Rules :: T_Rules -> Inh_Rules -> (Syn_Rules ) +wrap_Rules (T_Rules act) (Inh_Rules _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg34 = T_Rules_vIn34 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren + (T_Rules_vOut34 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules) <- return (inv_Rules_s35 sem arg34) + return (Syn_Rules _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules) + ) + +-- cata +{-# NOINLINE sem_Rules #-} +sem_Rules :: Rules -> T_Rules +sem_Rules list = Prelude.foldr sem_Rules_Cons sem_Rules_Nil (Prelude.map sem_Rule list) + +-- semantic domain +newtype T_Rules = T_Rules { + attach_T_Rules :: Identity (T_Rules_s35 ) + } +newtype T_Rules_s35 = C_Rules_s35 { + inv_Rules_s35 :: (T_Rules_v34 ) + } +data T_Rules_s36 = C_Rules_s36 +type T_Rules_v34 = (T_Rules_vIn34 ) -> (T_Rules_vOut34 ) +data T_Rules_vIn34 = T_Rules_vIn34 (Map Identifier Type) ([(Identifier,Type,ChildKind)]) ([Identifier]) (Map AltAttr Vertex) ([(Identifier,Identifier)]) (Map Identifier Attributes) (Map Identifier NontermIdent) (Identifier) (Attributes) (Map Identifier Attributes) (Map Identifier (Identifier,[Identifier])) (Identifier) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Bool) (Options) (String) (Attributes) (Map Identifier Attributes) +data T_Rules_vOut34 = T_Rules_vOut34 (Seq Edge) (Seq Error) ([AltAttr]) (Seq CRule) (Seq Edge) ([Identifier]) ([Identifier]) ([Mirage.Rule]) (Int) (Int) +{-# NOINLINE sem_Rules_Cons #-} +sem_Rules_Cons :: T_Rule -> T_Rules -> T_Rules +sem_Rules_Cons arg_hd_ arg_tl_ = T_Rules (return st35) where + {-# NOINLINE st35 #-} + st35 = let + v34 :: T_Rules_v34 + v34 = \ (T_Rules_vIn34 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) -> ( let + _hdX32 = Control.Monad.Identity.runIdentity (attach_T_Rule (arg_hd_)) + _tlX35 = Control.Monad.Identity.runIdentity (attach_T_Rules (arg_tl_)) + (T_Rule_vOut31 _hdIdirectDep _hdIerrors _hdIgathAltAttrs _hdIgathRules _hdIinstDep _hdIinstVars _hdIlocVars _hdImirage _hdInAutoRules _hdInExplicitRules) = inv_Rule_s32 _hdX32 (T_Rule_vIn31 _hdOallTypeSigs _hdOallfields _hdOallnts _hdOaltAttrs _hdOattrs _hdOchildInhs _hdOchildNts _hdOcon _hdOinh _hdOinhsOfChildren _hdOmergeMap _hdOnt _hdOo_case _hdOo_cata _hdOo_dovisit _hdOo_newtypes _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_wantvisit _hdOoptions _hdOprefix _hdOsyn _hdOsynsOfChildren) + (T_Rules_vOut34 _tlIdirectDep _tlIerrors _tlIgathAltAttrs _tlIgathRules _tlIinstDep _tlIinstVars _tlIlocVars _tlImirages _tlInAutoRules _tlInExplicitRules) = inv_Rules_s35 _tlX35 (T_Rules_vIn34 _tlOallTypeSigs _tlOallfields _tlOallnts _tlOaltAttrs _tlOattrs _tlOchildInhs _tlOchildNts _tlOcon _tlOinh _tlOinhsOfChildren _tlOmergeMap _tlOnt _tlOo_case _tlOo_cata _tlOo_dovisit _tlOo_newtypes _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_wantvisit _tlOoptions _tlOprefix _tlOsyn _tlOsynsOfChildren) + _lhsOmirages :: [Mirage.Rule] + _lhsOmirages = rule506 _hdImirage _tlImirages + _lhsOdirectDep :: Seq Edge + _lhsOdirectDep = rule507 _hdIdirectDep _tlIdirectDep + _lhsOerrors :: Seq Error + _lhsOerrors = rule508 _hdIerrors _tlIerrors + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule509 _hdIgathAltAttrs _tlIgathAltAttrs + _lhsOgathRules :: Seq CRule + _lhsOgathRules = rule510 _hdIgathRules _tlIgathRules + _lhsOinstDep :: Seq Edge + _lhsOinstDep = rule511 _hdIinstDep _tlIinstDep + _lhsOinstVars :: [Identifier] + _lhsOinstVars = rule512 _hdIinstVars _tlIinstVars + _lhsOlocVars :: [Identifier] + _lhsOlocVars = rule513 _hdIlocVars _tlIlocVars + _lhsOnAutoRules :: Int + _lhsOnAutoRules = rule514 _hdInAutoRules _tlInAutoRules + _lhsOnExplicitRules :: Int + _lhsOnExplicitRules = rule515 _hdInExplicitRules _tlInExplicitRules + _hdOallTypeSigs = rule516 _lhsIallTypeSigs + _hdOallfields = rule517 _lhsIallfields + _hdOallnts = rule518 _lhsIallnts + _hdOaltAttrs = rule519 _lhsIaltAttrs + _hdOattrs = rule520 _lhsIattrs + _hdOchildInhs = rule521 _lhsIchildInhs + _hdOchildNts = rule522 _lhsIchildNts + _hdOcon = rule523 _lhsIcon + _hdOinh = rule524 _lhsIinh + _hdOinhsOfChildren = rule525 _lhsIinhsOfChildren + _hdOmergeMap = rule526 _lhsImergeMap + _hdOnt = rule527 _lhsInt + _hdOo_case = rule528 _lhsIo_case + _hdOo_cata = rule529 _lhsIo_cata + _hdOo_dovisit = rule530 _lhsIo_dovisit + _hdOo_newtypes = rule531 _lhsIo_newtypes + _hdOo_rename = rule532 _lhsIo_rename + _hdOo_sem = rule533 _lhsIo_sem + _hdOo_sig = rule534 _lhsIo_sig + _hdOo_wantvisit = rule535 _lhsIo_wantvisit + _hdOoptions = rule536 _lhsIoptions + _hdOprefix = rule537 _lhsIprefix + _hdOsyn = rule538 _lhsIsyn + _hdOsynsOfChildren = rule539 _lhsIsynsOfChildren + _tlOallTypeSigs = rule540 _lhsIallTypeSigs + _tlOallfields = rule541 _lhsIallfields + _tlOallnts = rule542 _lhsIallnts + _tlOaltAttrs = rule543 _lhsIaltAttrs + _tlOattrs = rule544 _lhsIattrs + _tlOchildInhs = rule545 _lhsIchildInhs + _tlOchildNts = rule546 _lhsIchildNts + _tlOcon = rule547 _lhsIcon + _tlOinh = rule548 _lhsIinh + _tlOinhsOfChildren = rule549 _lhsIinhsOfChildren + _tlOmergeMap = rule550 _lhsImergeMap + _tlOnt = rule551 _lhsInt + _tlOo_case = rule552 _lhsIo_case + _tlOo_cata = rule553 _lhsIo_cata + _tlOo_dovisit = rule554 _lhsIo_dovisit + _tlOo_newtypes = rule555 _lhsIo_newtypes + _tlOo_rename = rule556 _lhsIo_rename + _tlOo_sem = rule557 _lhsIo_sem + _tlOo_sig = rule558 _lhsIo_sig + _tlOo_wantvisit = rule559 _lhsIo_wantvisit + _tlOoptions = rule560 _lhsIoptions + _tlOprefix = rule561 _lhsIprefix + _tlOsyn = rule562 _lhsIsyn + _tlOsynsOfChildren = rule563 _lhsIsynsOfChildren + __result_ = T_Rules_vOut34 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules + in __result_ ) + in C_Rules_s35 v34 + {-# INLINE rule506 #-} + {-# LINE 53 "src-ag/TfmToMirage.ag" #-} + rule506 = \ ((_hdImirage) :: Mirage.Rule) ((_tlImirages) :: [Mirage.Rule]) -> + {-# LINE 53 "src-ag/TfmToMirage.ag" #-} + _hdImirage : _tlImirages + {-# LINE 3775 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule507 #-} + rule507 = \ ((_hdIdirectDep) :: Seq Edge) ((_tlIdirectDep) :: Seq Edge) -> + _hdIdirectDep Seq.>< _tlIdirectDep + {-# INLINE rule508 #-} + rule508 = \ ((_hdIerrors) :: Seq Error) ((_tlIerrors) :: Seq Error) -> + _hdIerrors Seq.>< _tlIerrors + {-# INLINE rule509 #-} + rule509 = \ ((_hdIgathAltAttrs) :: [AltAttr]) ((_tlIgathAltAttrs) :: [AltAttr]) -> + _hdIgathAltAttrs ++ _tlIgathAltAttrs + {-# INLINE rule510 #-} + rule510 = \ ((_hdIgathRules) :: Seq CRule) ((_tlIgathRules) :: Seq CRule) -> + _hdIgathRules Seq.>< _tlIgathRules + {-# INLINE rule511 #-} + rule511 = \ ((_hdIinstDep) :: Seq Edge) ((_tlIinstDep) :: Seq Edge) -> + _hdIinstDep Seq.>< _tlIinstDep + {-# INLINE rule512 #-} + rule512 = \ ((_hdIinstVars) :: [Identifier]) ((_tlIinstVars) :: [Identifier]) -> + _hdIinstVars ++ _tlIinstVars + {-# INLINE rule513 #-} + rule513 = \ ((_hdIlocVars) :: [Identifier]) ((_tlIlocVars) :: [Identifier]) -> + _hdIlocVars ++ _tlIlocVars + {-# INLINE rule514 #-} + rule514 = \ ((_hdInAutoRules) :: Int) ((_tlInAutoRules) :: Int) -> + _hdInAutoRules + _tlInAutoRules + {-# INLINE rule515 #-} + rule515 = \ ((_hdInExplicitRules) :: Int) ((_tlInExplicitRules) :: Int) -> + _hdInExplicitRules + _tlInExplicitRules + {-# INLINE rule516 #-} + rule516 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> + _lhsIallTypeSigs + {-# INLINE rule517 #-} + rule517 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> + _lhsIallfields + {-# INLINE rule518 #-} + rule518 = \ ((_lhsIallnts) :: [Identifier]) -> + _lhsIallnts + {-# INLINE rule519 #-} + rule519 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> + _lhsIaltAttrs + {-# INLINE rule520 #-} + rule520 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> + _lhsIattrs + {-# INLINE rule521 #-} + rule521 = \ ((_lhsIchildInhs) :: Map Identifier Attributes) -> + _lhsIchildInhs + {-# INLINE rule522 #-} + rule522 = \ ((_lhsIchildNts) :: Map Identifier NontermIdent) -> + _lhsIchildNts + {-# INLINE rule523 #-} + rule523 = \ ((_lhsIcon) :: Identifier) -> + _lhsIcon + {-# INLINE rule524 #-} + rule524 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule525 #-} + rule525 = \ ((_lhsIinhsOfChildren) :: Map Identifier Attributes) -> + _lhsIinhsOfChildren + {-# INLINE rule526 #-} + rule526 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> + _lhsImergeMap + {-# INLINE rule527 #-} + rule527 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule528 #-} + rule528 = \ ((_lhsIo_case) :: Bool) -> + _lhsIo_case + {-# INLINE rule529 #-} + rule529 = \ ((_lhsIo_cata) :: Bool) -> + _lhsIo_cata + {-# INLINE rule530 #-} + rule530 = \ ((_lhsIo_dovisit) :: Bool) -> + _lhsIo_dovisit + {-# INLINE rule531 #-} + rule531 = \ ((_lhsIo_newtypes) :: Bool) -> + _lhsIo_newtypes + {-# INLINE rule532 #-} + rule532 = \ ((_lhsIo_rename) :: Bool) -> + _lhsIo_rename + {-# INLINE rule533 #-} + rule533 = \ ((_lhsIo_sem) :: Bool) -> + _lhsIo_sem + {-# INLINE rule534 #-} + rule534 = \ ((_lhsIo_sig) :: Bool) -> + _lhsIo_sig + {-# INLINE rule535 #-} + rule535 = \ ((_lhsIo_wantvisit) :: Bool) -> + _lhsIo_wantvisit + {-# INLINE rule536 #-} + rule536 = \ ((_lhsIoptions) :: Options) -> + _lhsIoptions + {-# INLINE rule537 #-} + rule537 = \ ((_lhsIprefix) :: String) -> + _lhsIprefix + {-# INLINE rule538 #-} + rule538 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn + {-# INLINE rule539 #-} + rule539 = \ ((_lhsIsynsOfChildren) :: Map Identifier Attributes) -> + _lhsIsynsOfChildren + {-# INLINE rule540 #-} + rule540 = \ ((_lhsIallTypeSigs) :: Map Identifier Type) -> + _lhsIallTypeSigs + {-# INLINE rule541 #-} + rule541 = \ ((_lhsIallfields) :: [(Identifier,Type,ChildKind)]) -> + _lhsIallfields + {-# INLINE rule542 #-} + rule542 = \ ((_lhsIallnts) :: [Identifier]) -> + _lhsIallnts + {-# INLINE rule543 #-} + rule543 = \ ((_lhsIaltAttrs) :: Map AltAttr Vertex) -> + _lhsIaltAttrs + {-# INLINE rule544 #-} + rule544 = \ ((_lhsIattrs) :: [(Identifier,Identifier)]) -> + _lhsIattrs + {-# INLINE rule545 #-} + rule545 = \ ((_lhsIchildInhs) :: Map Identifier Attributes) -> + _lhsIchildInhs + {-# INLINE rule546 #-} + rule546 = \ ((_lhsIchildNts) :: Map Identifier NontermIdent) -> + _lhsIchildNts + {-# INLINE rule547 #-} + rule547 = \ ((_lhsIcon) :: Identifier) -> + _lhsIcon + {-# INLINE rule548 #-} + rule548 = \ ((_lhsIinh) :: Attributes) -> + _lhsIinh + {-# INLINE rule549 #-} + rule549 = \ ((_lhsIinhsOfChildren) :: Map Identifier Attributes) -> + _lhsIinhsOfChildren + {-# INLINE rule550 #-} + rule550 = \ ((_lhsImergeMap) :: Map Identifier (Identifier,[Identifier])) -> + _lhsImergeMap + {-# INLINE rule551 #-} + rule551 = \ ((_lhsInt) :: Identifier) -> + _lhsInt + {-# INLINE rule552 #-} + rule552 = \ ((_lhsIo_case) :: Bool) -> + _lhsIo_case + {-# INLINE rule553 #-} + rule553 = \ ((_lhsIo_cata) :: Bool) -> + _lhsIo_cata + {-# INLINE rule554 #-} + rule554 = \ ((_lhsIo_dovisit) :: Bool) -> + _lhsIo_dovisit + {-# INLINE rule555 #-} + rule555 = \ ((_lhsIo_newtypes) :: Bool) -> + _lhsIo_newtypes + {-# INLINE rule556 #-} + rule556 = \ ((_lhsIo_rename) :: Bool) -> + _lhsIo_rename + {-# INLINE rule557 #-} + rule557 = \ ((_lhsIo_sem) :: Bool) -> + _lhsIo_sem + {-# INLINE rule558 #-} + rule558 = \ ((_lhsIo_sig) :: Bool) -> + _lhsIo_sig + {-# INLINE rule559 #-} + rule559 = \ ((_lhsIo_wantvisit) :: Bool) -> + _lhsIo_wantvisit + {-# INLINE rule560 #-} + rule560 = \ ((_lhsIoptions) :: Options) -> + _lhsIoptions + {-# INLINE rule561 #-} + rule561 = \ ((_lhsIprefix) :: String) -> + _lhsIprefix + {-# INLINE rule562 #-} + rule562 = \ ((_lhsIsyn) :: Attributes) -> + _lhsIsyn + {-# INLINE rule563 #-} + rule563 = \ ((_lhsIsynsOfChildren) :: Map Identifier Attributes) -> + _lhsIsynsOfChildren +{-# NOINLINE sem_Rules_Nil #-} +sem_Rules_Nil :: T_Rules +sem_Rules_Nil = T_Rules (return st35) where + {-# NOINLINE st35 #-} + st35 = let + v34 :: T_Rules_v34 + v34 = \ (T_Rules_vIn34 _lhsIallTypeSigs _lhsIallfields _lhsIallnts _lhsIaltAttrs _lhsIattrs _lhsIchildInhs _lhsIchildNts _lhsIcon _lhsIinh _lhsIinhsOfChildren _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_dovisit _lhsIo_newtypes _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_wantvisit _lhsIoptions _lhsIprefix _lhsIsyn _lhsIsynsOfChildren) -> ( let + _lhsOmirages :: [Mirage.Rule] + _lhsOmirages = rule564 () + _lhsOdirectDep :: Seq Edge + _lhsOdirectDep = rule565 () + _lhsOerrors :: Seq Error + _lhsOerrors = rule566 () + _lhsOgathAltAttrs :: [AltAttr] + _lhsOgathAltAttrs = rule567 () + _lhsOgathRules :: Seq CRule + _lhsOgathRules = rule568 () + _lhsOinstDep :: Seq Edge + _lhsOinstDep = rule569 () + _lhsOinstVars :: [Identifier] + _lhsOinstVars = rule570 () + _lhsOlocVars :: [Identifier] + _lhsOlocVars = rule571 () + _lhsOnAutoRules :: Int + _lhsOnAutoRules = rule572 () + _lhsOnExplicitRules :: Int + _lhsOnExplicitRules = rule573 () + __result_ = T_Rules_vOut34 _lhsOdirectDep _lhsOerrors _lhsOgathAltAttrs _lhsOgathRules _lhsOinstDep _lhsOinstVars _lhsOlocVars _lhsOmirages _lhsOnAutoRules _lhsOnExplicitRules + in __result_ ) + in C_Rules_s35 v34 + {-# INLINE rule564 #-} + {-# LINE 54 "src-ag/TfmToMirage.ag" #-} + rule564 = \ (_ :: ()) -> + {-# LINE 54 "src-ag/TfmToMirage.ag" #-} + [] + {-# LINE 3982 "src-generated/TfmToMirage.hs" #-} + {-# INLINE rule565 #-} + rule565 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule566 #-} + rule566 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule567 #-} + rule567 = \ (_ :: ()) -> + [] + {-# INLINE rule568 #-} + rule568 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule569 #-} + rule569 = \ (_ :: ()) -> + Seq.empty + {-# INLINE rule570 #-} + rule570 = \ (_ :: ()) -> + [] + {-# INLINE rule571 #-} + rule571 = \ (_ :: ()) -> + [] + {-# INLINE rule572 #-} + rule572 = \ (_ :: ()) -> + 0 + {-# INLINE rule573 #-} + rule573 = \ (_ :: ()) -> + 0 + +-- TypeSig ----------------------------------------------------- +-- wrapper +data Inh_TypeSig = Inh_TypeSig { typeSigs_Inh_TypeSig :: (Map Identifier Type) } +data Syn_TypeSig = Syn_TypeSig { typeSigs_Syn_TypeSig :: (Map Identifier Type) } +{-# INLINABLE wrap_TypeSig #-} +wrap_TypeSig :: T_TypeSig -> Inh_TypeSig -> (Syn_TypeSig ) +wrap_TypeSig (T_TypeSig act) (Inh_TypeSig _lhsItypeSigs) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg37 = T_TypeSig_vIn37 _lhsItypeSigs + (T_TypeSig_vOut37 _lhsOtypeSigs) <- return (inv_TypeSig_s38 sem arg37) + return (Syn_TypeSig _lhsOtypeSigs) + ) + +-- cata +{-# INLINE sem_TypeSig #-} +sem_TypeSig :: TypeSig -> T_TypeSig +sem_TypeSig ( TypeSig name_ tp_ ) = sem_TypeSig_TypeSig name_ tp_ + +-- semantic domain +newtype T_TypeSig = T_TypeSig { + attach_T_TypeSig :: Identity (T_TypeSig_s38 ) + } +newtype T_TypeSig_s38 = C_TypeSig_s38 { + inv_TypeSig_s38 :: (T_TypeSig_v37 ) + } +data T_TypeSig_s39 = C_TypeSig_s39 +type T_TypeSig_v37 = (T_TypeSig_vIn37 ) -> (T_TypeSig_vOut37 ) +data T_TypeSig_vIn37 = T_TypeSig_vIn37 (Map Identifier Type) +data T_TypeSig_vOut37 = T_TypeSig_vOut37 (Map Identifier Type) +{-# NOINLINE sem_TypeSig_TypeSig #-} +sem_TypeSig_TypeSig :: (Identifier) -> (Type) -> T_TypeSig +sem_TypeSig_TypeSig arg_name_ arg_tp_ = T_TypeSig (return st38) where + {-# NOINLINE st38 #-} + st38 = let + v37 :: T_TypeSig_v37 + v37 = \ (T_TypeSig_vIn37 _lhsItypeSigs) -> ( let + _lhsOtypeSigs :: Map Identifier Type + _lhsOtypeSigs = rule574 _lhsItypeSigs arg_name_ arg_tp_ + __result_ = T_TypeSig_vOut37 _lhsOtypeSigs + in __result_ ) + in C_TypeSig_s38 v37 + {-# INLINE rule574 #-} + {-# LINE 536 "src-ag/Order.ag" #-} + rule574 = \ ((_lhsItypeSigs) :: Map Identifier Type) name_ tp_ -> + {-# LINE 536 "src-ag/Order.ag" #-} + Map.insert name_ tp_ _lhsItypeSigs + {-# LINE 4058 "src-generated/TfmToMirage.hs" #-} + +-- TypeSigs ---------------------------------------------------- +-- wrapper +data Inh_TypeSigs = Inh_TypeSigs { typeSigs_Inh_TypeSigs :: (Map Identifier Type) } +data Syn_TypeSigs = Syn_TypeSigs { typeSigs_Syn_TypeSigs :: (Map Identifier Type) } +{-# INLINABLE wrap_TypeSigs #-} +wrap_TypeSigs :: T_TypeSigs -> Inh_TypeSigs -> (Syn_TypeSigs ) +wrap_TypeSigs (T_TypeSigs act) (Inh_TypeSigs _lhsItypeSigs) = + Control.Monad.Identity.runIdentity ( + do sem <- act + let arg40 = T_TypeSigs_vIn40 _lhsItypeSigs + (T_TypeSigs_vOut40 _lhsOtypeSigs) <- return (inv_TypeSigs_s41 sem arg40) + return (Syn_TypeSigs _lhsOtypeSigs) + ) + +-- cata +{-# NOINLINE sem_TypeSigs #-} +sem_TypeSigs :: TypeSigs -> T_TypeSigs +sem_TypeSigs list = Prelude.foldr sem_TypeSigs_Cons sem_TypeSigs_Nil (Prelude.map sem_TypeSig list) + +-- semantic domain +newtype T_TypeSigs = T_TypeSigs { + attach_T_TypeSigs :: Identity (T_TypeSigs_s41 ) + } +newtype T_TypeSigs_s41 = C_TypeSigs_s41 { + inv_TypeSigs_s41 :: (T_TypeSigs_v40 ) + } +data T_TypeSigs_s42 = C_TypeSigs_s42 +type T_TypeSigs_v40 = (T_TypeSigs_vIn40 ) -> (T_TypeSigs_vOut40 ) +data T_TypeSigs_vIn40 = T_TypeSigs_vIn40 (Map Identifier Type) +data T_TypeSigs_vOut40 = T_TypeSigs_vOut40 (Map Identifier Type) +{-# NOINLINE sem_TypeSigs_Cons #-} +sem_TypeSigs_Cons :: T_TypeSig -> T_TypeSigs -> T_TypeSigs +sem_TypeSigs_Cons arg_hd_ arg_tl_ = T_TypeSigs (return st41) where + {-# NOINLINE st41 #-} + st41 = let + v40 :: T_TypeSigs_v40 + v40 = \ (T_TypeSigs_vIn40 _lhsItypeSigs) -> ( let + _hdX38 = Control.Monad.Identity.runIdentity (attach_T_TypeSig (arg_hd_)) + _tlX41 = Control.Monad.Identity.runIdentity (attach_T_TypeSigs (arg_tl_)) + (T_TypeSig_vOut37 _hdItypeSigs) = inv_TypeSig_s38 _hdX38 (T_TypeSig_vIn37 _hdOtypeSigs) + (T_TypeSigs_vOut40 _tlItypeSigs) = inv_TypeSigs_s41 _tlX41 (T_TypeSigs_vIn40 _tlOtypeSigs) + _lhsOtypeSigs :: Map Identifier Type + _lhsOtypeSigs = rule575 _tlItypeSigs + _hdOtypeSigs = rule576 _lhsItypeSigs + _tlOtypeSigs = rule577 _hdItypeSigs + __result_ = T_TypeSigs_vOut40 _lhsOtypeSigs + in __result_ ) + in C_TypeSigs_s41 v40 + {-# INLINE rule575 #-} + rule575 = \ ((_tlItypeSigs) :: Map Identifier Type) -> + _tlItypeSigs + {-# INLINE rule576 #-} + rule576 = \ ((_lhsItypeSigs) :: Map Identifier Type) -> + _lhsItypeSigs + {-# INLINE rule577 #-} + rule577 = \ ((_hdItypeSigs) :: Map Identifier Type) -> + _hdItypeSigs +{-# NOINLINE sem_TypeSigs_Nil #-} +sem_TypeSigs_Nil :: T_TypeSigs +sem_TypeSigs_Nil = T_TypeSigs (return st41) where + {-# NOINLINE st41 #-} + st41 = let + v40 :: T_TypeSigs_v40 + v40 = \ (T_TypeSigs_vIn40 _lhsItypeSigs) -> ( let + _lhsOtypeSigs :: Map Identifier Type + _lhsOtypeSigs = rule578 _lhsItypeSigs + __result_ = T_TypeSigs_vOut40 _lhsOtypeSigs + in __result_ ) + in C_TypeSigs_s41 v40 + {-# INLINE rule578 #-} + rule578 = \ ((_lhsItypeSigs) :: Map Identifier Type) -> + _lhsItypeSigs diff --git a/src-generated/TfmToVisage.hs b/src-generated/TfmToVisage.hs --- a/src-generated/TfmToVisage.hs +++ b/src-generated/TfmToVisage.hs @@ -3,95 +3,95 @@ module TfmToVisage where {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 10 "src-generated/TfmToVisage.hs" #-} {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 17 "src-generated/TfmToVisage.hs" #-} {-# LINE 2 "src-ag/AbstractSyntax.ag" #-} - --- AbstractSyntax.ag imports -import Data.Set(Set) -import Data.Map(Map) -import Patterns (Pattern(..),Patterns) -import Expression (Expression(..)) -import Macro --marcos -import CommonTypes -import ErrorMessages + +-- AbstractSyntax.ag imports +import Data.Set(Set) +import Data.Map(Map) +import Patterns (Pattern(..),Patterns) +import Expression (Expression(..)) +import Macro --marcos +import CommonTypes +import ErrorMessages {-# LINE 29 "src-generated/TfmToVisage.hs" #-} {-# LINE 9 "src-ag/TfmToVisage.ag" #-} - -import AbstractSyntax -import VisagePatterns -import VisageSyntax -import qualified Data.Map as Map -import Data.Map (Map) + +import AbstractSyntax +import VisagePatterns +import VisageSyntax +import qualified Data.Map as Map +import Data.Map (Map) {-# LINE 38 "src-generated/TfmToVisage.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 17 "src-ag/TfmToVisage.ag" #-} - --- Maps a rule to a pair --- Later, I expect to map to a list of rules, because we might need to unfold. - - --- Checks that a certain alias is in fact a Var in the old representation of the AG system -isVar (Alias _ _ (Underscore _)) = True -isVar _ = False - -type VisageRuleMap = [(String, VisageRule)] - -splitVRules :: [VisageRule] -> VisageRuleMap -splitVRules vrs = concat (map unfoldvrs vrs) - -unfoldvrs :: VisageRule -> VisageRuleMap -unfoldvrs vr@(VRule attrfields _ _ _ _) = zip (map (getName . fst) attrfields) (map (copyRule vr) attrfields) - -copyRule :: VisageRule -> (Identifier,Identifier) -> VisageRule -copyRule (VRule attrfields _ pat expr owrt) (field,attr) = VRule attrfields attr pat expr owrt - -getForField :: String -> VisageRuleMap -> [VisageRule] -getForField field xs = map snd (filter ((field ==) . fst) xs) - -{- - Delivers a map from fieldname to VisageRule with all references to others underscored. - So, (lhs.x, rt.y, loc.z) = (0,1,2) becomes something like - [("lhs", (lhs.x,_,_) = (0,1,2) - - At this point, we do not use this anymore. - -allways :: VisageRule -> VisageRuleMap -allways vr@(VRule vrfields _ _ _ _) = zip vrfields (map (underScoreRule vr) (nub vrfields)) - -splitVRules :: [VisageRule] -> VisageRuleMap -splitVRules vrs = concat (map allways vrs) - -underScoreRule :: VisageRule -> String -> VisageRule -underScoreRule (VRule fields pat expr owrt rule) s = VRule fields (underScore s pat) expr owrt rule - -underScore :: String -> VisagePattern -> VisagePattern -underScore field (VConstr name pats) = VConstr name (map (underScore field) pats) -underScore field (VProduct pos pats) = VProduct pos (map (underScore field) pats) -underScore field vp@(VVar vfield attr) = - if (field == getName vfield) - then vp - else (VUnderscore (getPos vfield)) --- Should I recurse into the pat of VAlias? -underScore field vp@(VAlias afield attr pat) = - if (field == getName afield) - then vp - else (VUnderscore (getPos afield)) -underScore field vp@(VUnderscore pos) = vp - --} + +-- Maps a rule to a pair +-- Later, I expect to map to a list of rules, because we might need to unfold. + + +-- Checks that a certain alias is in fact a Var in the old representation of the AG system +isVar (Alias _ _ (Underscore _)) = True +isVar _ = False + +type VisageRuleMap = [(String, VisageRule)] + +splitVRules :: [VisageRule] -> VisageRuleMap +splitVRules vrs = concat (map unfoldvrs vrs) + +unfoldvrs :: VisageRule -> VisageRuleMap +unfoldvrs vr@(VRule attrfields _ _ _ _) = zip (map (getName . fst) attrfields) (map (copyRule vr) attrfields) + +copyRule :: VisageRule -> (Identifier,Identifier) -> VisageRule +copyRule (VRule attrfields _ pat expr owrt) (field,attr) = VRule attrfields attr pat expr owrt + +getForField :: String -> VisageRuleMap -> [VisageRule] +getForField field xs = map snd (filter ((field ==) . fst) xs) + +{- + Delivers a map from fieldname to VisageRule with all references to others underscored. + So, (lhs.x, rt.y, loc.z) = (0,1,2) becomes something like + [("lhs", (lhs.x,_,_) = (0,1,2) + + At this point, we do not use this anymore. + +allways :: VisageRule -> VisageRuleMap +allways vr@(VRule vrfields _ _ _ _) = zip vrfields (map (underScoreRule vr) (nub vrfields)) + +splitVRules :: [VisageRule] -> VisageRuleMap +splitVRules vrs = concat (map allways vrs) + +underScoreRule :: VisageRule -> String -> VisageRule +underScoreRule (VRule fields pat expr owrt rule) s = VRule fields (underScore s pat) expr owrt rule + +underScore :: String -> VisagePattern -> VisagePattern +underScore field (VConstr name pats) = VConstr name (map (underScore field) pats) +underScore field (VProduct pos pats) = VProduct pos (map (underScore field) pats) +underScore field vp@(VVar vfield attr) = + if (field == getName vfield) + then vp + else (VUnderscore (getPos vfield)) +-- Should I recurse into the pat of VAlias? +underScore field vp@(VAlias afield attr pat) = + if (field == getName afield) + then vp + else (VUnderscore (getPos afield)) +underScore field vp@(VUnderscore pos) = vp + +-} {-# LINE 96 "src-generated/TfmToVisage.hs" #-} -- Child ------------------------------------------------------- -- wrapper diff --git a/src-generated/Transform.hs b/src-generated/Transform.hs --- a/src-generated/Transform.hs +++ b/src-generated/Transform.hs @@ -3,42 +3,42 @@ module Transform where {-# LINE 2 "src-ag/Patterns.ag" #-} - --- Patterns.ag imports -import UU.Scanner.Position(Pos) -import CommonTypes (ConstructorIdent,Identifier) + +-- Patterns.ag imports +import UU.Scanner.Position(Pos) +import CommonTypes (ConstructorIdent,Identifier) {-# LINE 11 "src-generated/Transform.hs" #-} {-# LINE 2 "src-ag/ConcreteSyntax.ag" #-} - -import UU.Scanner.Position (Pos) -import Patterns (Pattern) -import Expression (Expression) -import CommonTypes -import Macro --marcos + +import UU.Scanner.Position (Pos) +import Patterns (Pattern) +import Expression (Expression) +import CommonTypes +import Macro --marcos {-# LINE 20 "src-generated/Transform.hs" #-} {-# LINE 8 "src-ag/Transform.ag" #-} - -import Control.Monad(mplus,mzero) -import Data.List (partition, nub,intersperse, union) -import Data.Maybe -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Set as Set (Set, member, union, toList, fromList, empty, singleton, member, unions, size, fold, intersection, difference, insert, elems) -import qualified Data.Sequence as Seq -import Data.Sequence(Seq, (><)) -import UU.Scanner.Position(noPos) - -import ConcreteSyntax -import AbstractSyntax -import ErrorMessages -import Patterns (Patterns,Pattern(..)) -import Expression (Expression(..)) -import HsToken - -import RhsCheck -import Debug.Trace + +import Control.Monad(mplus,mzero) +import Data.List (partition, nub,intersperse, union) +import Data.Maybe +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Set as Set (Set, member, union, toList, fromList, empty, singleton, member, unions, size, fold, intersection, difference, insert, elems) +import qualified Data.Sequence as Seq +import Data.Sequence(Seq, (><)) +import UU.Scanner.Position(noPos) + +import ConcreteSyntax +import AbstractSyntax +import ErrorMessages +import Patterns (Patterns,Pattern(..)) +import Expression (Expression(..)) +import HsToken + +import RhsCheck +import Debug.Trace {-# LINE 43 "src-generated/Transform.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity @@ -83,431 +83,431 @@ {-# LINE 84 "src-generated/Transform.hs" #-} {-# LINE 203 "src-ag/Transform.ag" #-} - - -checkDuplicate :: (Identifier -> Identifier -> Error) - -> Identifier -> val -> Map Identifier val -> (Map Identifier val,Seq Error) -checkDuplicate dupError key val m - = case Map.lookupIndex key m of - Just ix -> let (key',_) = Map.elemAt ix m - in (m,Seq.singleton (dupError key key')) - Nothing -> (Map.insert key val m,Seq.empty) - -checkDuplicates :: (Identifier -> Identifier -> Error) - -> [(Identifier, val)] -> Map Identifier val -> (Map Identifier val,Seq Error) -checkDuplicates dupError new m = foldErrors check m new - where check = uncurry (checkDuplicate dupError) - -foldErrors :: (b -> t -> (t, Seq Error)) -> t -> [b] -> (t, Seq Error) -foldErrors f n xs = foldl g (n,Seq.empty) xs - where g ~(e,es) x = let (e',es') = f x e - in (e', es >< es') - - -checkForDuplicates :: (Identifier -> Identifier -> Error) -> [Identifier] -> [Error] -checkForDuplicates _ [] = [] -checkForDuplicates err (x:xs) = let (same,other) = partition (equalId x) xs - in map (err x) same ++ checkForDuplicates err other - -equalId :: Identifier -> Identifier -> Bool -equalId x y = getName x == getName y - + + +checkDuplicate :: (Identifier -> Identifier -> Error) + -> Identifier -> val -> Map Identifier val -> (Map Identifier val,Seq Error) +checkDuplicate dupError key val m + = case Map.lookupIndex key m of + Just ix -> let (key',_) = Map.elemAt ix m + in (m,Seq.singleton (dupError key key')) + Nothing -> (Map.insert key val m,Seq.empty) + +checkDuplicates :: (Identifier -> Identifier -> Error) + -> [(Identifier, val)] -> Map Identifier val -> (Map Identifier val,Seq Error) +checkDuplicates dupError new m = foldErrors check m new + where check = uncurry (checkDuplicate dupError) + +foldErrors :: (b -> t -> (t, Seq Error)) -> t -> [b] -> (t, Seq Error) +foldErrors f n xs = foldl g (n,Seq.empty) xs + where g ~(e,es) x = let (e',es') = f x e + in (e', es >< es') + + +checkForDuplicates :: (Identifier -> Identifier -> Error) -> [Identifier] -> [Error] +checkForDuplicates _ [] = [] +checkForDuplicates err (x:xs) = let (same,other) = partition (equalId x) xs + in map (err x) same ++ checkForDuplicates err other + +equalId :: Identifier -> Identifier -> Bool +equalId x y = getName x == getName y + {-# LINE 116 "src-generated/Transform.hs" #-} {-# LINE 354 "src-ag/Transform.ag" #-} - -type RulesAndErrors = ([Rule], Seq Error) -type SigsAndErrors = ([TypeSig], Seq Error) -type InstsAndErrors = ([(Identifier, Type)], Seq Error) -type UniquesAndErrors = (Map Identifier Identifier, Seq Error) -type AugmentsAndErrors = (Map Identifier [Expression], Seq Error) -type AroundsAndErrors = (Map Identifier [Expression], Seq Error) -type MergesAndErrors = (Map Identifier (Identifier, [Identifier], Expression), Seq Error) -type AttrOverwrite = Map AttrName Bool -type AccumRuleCheck = (RulesAndErrors, AttrOverwrite) -type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName]) - -checkRules :: Map NontermIdent (Attributes, Attributes) -> DataTypes -> - Map NontermIdent (Map ConstructorIdent [Identifier]) -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> - Map NontermIdent (Map ConstructorIdent [MergeInfo]) -> - NontermIdent -> ConstructorIdent -> [RuleInfo] -> RulesAndErrors -checkRules attributes fields allinsts allsigs _ nt con rs - = let fieldmap :: FieldMap - fieldmap = (_LHS, NT nt [] False) : (_LOC, NT nullIdent [] False) : (_INST, NT nullIdent [] False) : (_FIRST, NT nullIdent [] False) : (_LAST, NT nullIdent [] False) - : Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fields) - ++ mapMaybe (\instNm -> lookup instNm sigs >>= \tp -> return (instNm, tp)) (Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allinsts)) - -- merged children are not allowed to have any inherited attrs defined: do not include - - sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allsigs) - - hasAttrib f tp attr = Map.member attr (f (Map.findWithDefault (Map.empty,Map.empty) tp attributes)) - - checkRule :: RuleInfo -> AccumRuleCheck -> AccumRuleCheck - checkRule (mbNm, pat,ex,as,owrt,str, pur, eager) ((r1,e1),m1) - = let (e2,m2,u2,_) = foldr (checkDefi owrt) (e1,m1,[],[]) as - in ( (Rule mbNm (pat u2) ex owrt str True pur False Nothing eager : r1, e2), m2) - - checkDefi :: Bool -> AttrName -> AccumDefiCheck -> AccumDefiCheck - checkDefi owrt fa@(field,attr) (e,m,u,bs) - = case lookup field fieldmap - of Just (NT tp _ _) -> - let tp' = maybe tp id (deforestedNt tp) - in if field == _LOC || field == _INST || field == _FIRST || field == _LAST - || hasAttrib (if getName field==getName _LHS then snd else fst) tp' attr - then case Map.lookupIndex fa m of - Just ix -> let ((_,attr2),b) = Map.elemAt ix m - in if b && not (fa `elem` bs) - then ( e, Map.insert fa owrt m, fa:u, fa:bs) - else (((Seq.<|)) (DupRule nt con field attr2 attr) e, m, fa:u, bs) - Nothing -> ( e, Map.insert fa owrt m, u, fa:bs) - else (((Seq.<|)) (SuperfluousRule nt con field attr) e, m, fa:u, bs) - _ -> (((Seq.<|)) (UndefChild nt con field) e, m, fa:u, bs ) - - in fst (foldr checkRule (([],Seq.empty),Map.empty) rs) - -checkRuleNames :: NontermIdent -> ConstructorIdent -> [RuleInfo] -> Seq Error -checkRuleNames nt con - = fst . foldr checkRule (Seq.empty, Set.empty) - where - checkRule (Just nm,_,_,_,_,_,_,_) (errs, nms) - | nm `Set.member` nms = (DupRuleName nt con nm Seq.<| errs, nms) - | otherwise = (errs, Set.insert nm nms) - checkRule (Nothing,_,_,_,_,_,_,_) inp = inp - -checkSigs :: NontermIdent -> ConstructorIdent -> [SigInfo] -> SigsAndErrors -checkSigs nt con sis - = let checkSig (ide,typ) (sigs,errs) - = if ide `elem` map (\(TypeSig n _)-> n) sigs - then (sigs, ((Seq.<|)) (DupSig nt con ide) errs) - -- else if not (ide `elem` locattrdefs) - -- then (sigs, ((Seq.<|)) (SupSig nt con ide) errs) - else (TypeSig ide typ:sigs, errs) - in foldr checkSig ([],Seq.empty) sis - -checkInsts :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [Identifier] -> InstsAndErrors -checkInsts allNts sigMap _ nt con - = foldr (\inst (insts, errs) -> - maybe (insts, Seq.singleton (MissingInstSig nt con inst) >< errs) - (\info@(k, NT nm args _) -> - case findInst k insts of - Just k' -> (insts, Seq.singleton (DupChild nt con k k') >< errs) - Nothing -> case nm `Set.member` allNts of - True -> (info : insts, errs) - False | take 2 (getName nm) == "T_" -> let nm' = Ident (drop 2 (getName nm)) (getPos nm) - info' = (k, NT nm' args True) -- this should be the only place at which 'for' with value True can be generated - in case nm' `Set.member` allNts of - True -> (info' : insts, errs) - False -> (insts, Seq.singleton (UndefNont nm') >< errs) - | otherwise -> (insts, Seq.singleton (UndefNont nm) >< errs) - ) - $ findSig inst - ) ([], Seq.empty) - where - sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt sigMap) - - findSig name - = do tp@(NT _ _ _) <- lookup name sigs - return (name, tp) - - findInst _ [] = Nothing - findInst k ((k', _): r) - | k == k' = Just k' - | otherwise = findInst k r - -checkUniques :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [UniqueInfo] -> UniquesAndErrors -checkUniques allAttrs nt con uniques - = let checkUnique (ident,ref) (us,errs) - = if ident `Map.member` us - then (us, ((Seq.<|)) (DupUnique nt con ident) errs) - else if Map.member ref inhs && Map.member ref syns - then (Map.insert ident ref us, errs) - else (us, ((Seq.<|)) (MissingUnique nt ref) errs) - - (inhs,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs - in foldr checkUnique (Map.empty, Seq.empty) uniques - -checkAugments :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [AugmentInfo] -> AugmentsAndErrors -checkAugments allAttrs nt _ augments - = let checkAugment (ident,expr) (as,errs) - = if ident `Map.member` as - then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs) - else if Map.member ident syns - then (Map.insert ident [expr] as, errs) - else (as, ((Seq.<|)) (MissingSyn nt ident) errs) - - (_,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs - in foldr checkAugment (Map.empty, Seq.empty) augments - -checkArounds :: DataTypes -> NontermIdent -> ConstructorIdent -> [AroundInfo] -> AroundsAndErrors -checkArounds fieldMap nt con arounds - = let checkAround (ident,expr) (as,errs) - = if ident `Map.member` as - then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs) - else case lookup ident fields of - Just (NT _ _ _) -> (Map.insert ident [expr] as, errs) - _ -> (as, ((Seq.<|)) (UndefChild nt con ident) errs) - fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap) - in foldr checkAround (Map.empty, Seq.empty) arounds - -checkMerges :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [Identifier]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [MergeInfo] -> MergesAndErrors -checkMerges allNts allInsts fieldMap _ con merges - = let checkMerge (target,nt,sources,expr) (m,errs) - = let fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap) - insts = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts) - allFields = insts ++ map fst fields -- note: sources of merge may not contain a target (for simplicity) - in if target `Map.member` m -- check for duplicate with self - then (m, DupChild nt con target (fst $ Map.elemAt (Map.findIndex target m) m) Seq.<| errs) - else if target `elem` allFields - then (m, DupChild nt con target (head $ filter (== target) allFields) Seq.<| errs) - else let missing = filter (\s -> not (s `elem` allFields)) sources - in if null missing - then if nt `Set.member` allNts -- check if the nonterm is defined - then (Map.insert target (nt, sources, expr) m, errs) -- all ok.. - else (m, UndefNont nt Seq.<| errs) - else (m, (Seq.fromList $ map (UndefChild nt con) missing) Seq.>< errs) - in foldr checkMerge (Map.empty, Seq.empty) merges - -unionunionplusplus :: Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -unionunionplusplus = Map.unionWith (Map.unionWith (++)) + +type RulesAndErrors = ([Rule], Seq Error) +type SigsAndErrors = ([TypeSig], Seq Error) +type InstsAndErrors = ([(Identifier, Type)], Seq Error) +type UniquesAndErrors = (Map Identifier Identifier, Seq Error) +type AugmentsAndErrors = (Map Identifier [Expression], Seq Error) +type AroundsAndErrors = (Map Identifier [Expression], Seq Error) +type MergesAndErrors = (Map Identifier (Identifier, [Identifier], Expression), Seq Error) +type AttrOverwrite = Map AttrName Bool +type AccumRuleCheck = (RulesAndErrors, AttrOverwrite) +type AccumDefiCheck = (Seq Error, AttrOverwrite, [AttrName], [AttrName]) + +checkRules :: Map NontermIdent (Attributes, Attributes) -> DataTypes -> + Map NontermIdent (Map ConstructorIdent [Identifier]) -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> + Map NontermIdent (Map ConstructorIdent [MergeInfo]) -> + NontermIdent -> ConstructorIdent -> [RuleInfo] -> RulesAndErrors +checkRules attributes fields allinsts allsigs _ nt con rs + = let fieldmap :: FieldMap + fieldmap = (_LHS, NT nt [] False) : (_LOC, NT nullIdent [] False) : (_INST, NT nullIdent [] False) : (_FIRST, NT nullIdent [] False) : (_LAST, NT nullIdent [] False) + : Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fields) + ++ mapMaybe (\instNm -> lookup instNm sigs >>= \tp -> return (instNm, tp)) (Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allinsts)) + -- merged children are not allowed to have any inherited attrs defined: do not include + + sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allsigs) + + hasAttrib f tp attr = Map.member attr (f (Map.findWithDefault (Map.empty,Map.empty) tp attributes)) + + checkRule :: RuleInfo -> AccumRuleCheck -> AccumRuleCheck + checkRule (mbNm, pat,ex,as,owrt,str, pur, eager) ((r1,e1),m1) + = let (e2,m2,u2,_) = foldr (checkDefi owrt) (e1,m1,[],[]) as + in ( (Rule mbNm (pat u2) ex owrt str True pur False Nothing eager : r1, e2), m2) + + checkDefi :: Bool -> AttrName -> AccumDefiCheck -> AccumDefiCheck + checkDefi owrt fa@(field,attr) (e,m,u,bs) + = case lookup field fieldmap + of Just (NT tp _ _) -> + let tp' = maybe tp id (deforestedNt tp) + in if field == _LOC || field == _INST || field == _FIRST || field == _LAST + || hasAttrib (if getName field==getName _LHS then snd else fst) tp' attr + then case Map.lookupIndex fa m of + Just ix -> let ((_,attr2),b) = Map.elemAt ix m + in if b && not (fa `elem` bs) + then ( e, Map.insert fa owrt m, fa:u, fa:bs) + else (((Seq.<|)) (DupRule nt con field attr2 attr) e, m, fa:u, bs) + Nothing -> ( e, Map.insert fa owrt m, u, fa:bs) + else (((Seq.<|)) (SuperfluousRule nt con field attr) e, m, fa:u, bs) + _ -> (((Seq.<|)) (UndefChild nt con field) e, m, fa:u, bs ) + + in fst (foldr checkRule (([],Seq.empty),Map.empty) rs) + +checkRuleNames :: NontermIdent -> ConstructorIdent -> [RuleInfo] -> Seq Error +checkRuleNames nt con + = fst . foldr checkRule (Seq.empty, Set.empty) + where + checkRule (Just nm,_,_,_,_,_,_,_) (errs, nms) + | nm `Set.member` nms = (DupRuleName nt con nm Seq.<| errs, nms) + | otherwise = (errs, Set.insert nm nms) + checkRule (Nothing,_,_,_,_,_,_,_) inp = inp + +checkSigs :: NontermIdent -> ConstructorIdent -> [SigInfo] -> SigsAndErrors +checkSigs nt con sis + = let checkSig (ide,typ) (sigs,errs) + = if ide `elem` map (\(TypeSig n _)-> n) sigs + then (sigs, ((Seq.<|)) (DupSig nt con ide) errs) + -- else if not (ide `elem` locattrdefs) + -- then (sigs, ((Seq.<|)) (SupSig nt con ide) errs) + else (TypeSig ide typ:sigs, errs) + in foldr checkSig ([],Seq.empty) sis + +checkInsts :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [SigInfo]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [Identifier] -> InstsAndErrors +checkInsts allNts sigMap _ nt con + = foldr (\inst (insts, errs) -> + maybe (insts, Seq.singleton (MissingInstSig nt con inst) >< errs) + (\info@(k, NT nm args _) -> + case findInst k insts of + Just k' -> (insts, Seq.singleton (DupChild nt con k k') >< errs) + Nothing -> case nm `Set.member` allNts of + True -> (info : insts, errs) + False | take 2 (getName nm) == "T_" -> let nm' = Ident (drop 2 (getName nm)) (getPos nm) + info' = (k, NT nm' args True) -- this should be the only place at which 'for' with value True can be generated + in case nm' `Set.member` allNts of + True -> (info' : insts, errs) + False -> (insts, Seq.singleton (UndefNont nm') >< errs) + | otherwise -> (insts, Seq.singleton (UndefNont nm) >< errs) + ) + $ findSig inst + ) ([], Seq.empty) + where + sigs = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt sigMap) + + findSig name + = do tp@(NT _ _ _) <- lookup name sigs + return (name, tp) + + findInst _ [] = Nothing + findInst k ((k', _): r) + | k == k' = Just k' + | otherwise = findInst k r + +checkUniques :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [UniqueInfo] -> UniquesAndErrors +checkUniques allAttrs nt con uniques + = let checkUnique (ident,ref) (us,errs) + = if ident `Map.member` us + then (us, ((Seq.<|)) (DupUnique nt con ident) errs) + else if Map.member ref inhs && Map.member ref syns + then (Map.insert ident ref us, errs) + else (us, ((Seq.<|)) (MissingUnique nt ref) errs) + + (inhs,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs + in foldr checkUnique (Map.empty, Seq.empty) uniques + +checkAugments :: Map NontermIdent (Attributes, Attributes) -> NontermIdent -> ConstructorIdent -> [AugmentInfo] -> AugmentsAndErrors +checkAugments allAttrs nt _ augments + = let checkAugment (ident,expr) (as,errs) + = if ident `Map.member` as + then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs) + else if Map.member ident syns + then (Map.insert ident [expr] as, errs) + else (as, ((Seq.<|)) (MissingSyn nt ident) errs) + + (_,syns) = Map.findWithDefault (Map.empty,Map.empty) nt allAttrs + in foldr checkAugment (Map.empty, Seq.empty) augments + +checkArounds :: DataTypes -> NontermIdent -> ConstructorIdent -> [AroundInfo] -> AroundsAndErrors +checkArounds fieldMap nt con arounds + = let checkAround (ident,expr) (as,errs) + = if ident `Map.member` as + then (Map.update (\vs -> Just (vs ++ [expr])) ident as, errs) + else case lookup ident fields of + Just (NT _ _ _) -> (Map.insert ident [expr] as, errs) + _ -> (as, ((Seq.<|)) (UndefChild nt con ident) errs) + fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap) + in foldr checkAround (Map.empty, Seq.empty) arounds + +checkMerges :: Set NontermIdent -> Map NontermIdent (Map ConstructorIdent [Identifier]) -> DataTypes -> NontermIdent -> ConstructorIdent -> [MergeInfo] -> MergesAndErrors +checkMerges allNts allInsts fieldMap _ con merges + = let checkMerge (target,nt,sources,expr) (m,errs) + = let fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt fieldMap) + insts = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts) + allFields = insts ++ map fst fields -- note: sources of merge may not contain a target (for simplicity) + in if target `Map.member` m -- check for duplicate with self + then (m, DupChild nt con target (fst $ Map.elemAt (Map.findIndex target m) m) Seq.<| errs) + else if target `elem` allFields + then (m, DupChild nt con target (head $ filter (== target) allFields) Seq.<| errs) + else let missing = filter (\s -> not (s `elem` allFields)) sources + in if null missing + then if nt `Set.member` allNts -- check if the nonterm is defined + then (Map.insert target (nt, sources, expr) m, errs) -- all ok.. + else (m, UndefNont nt Seq.<| errs) + else (m, (Seq.fromList $ map (UndefChild nt con) missing) Seq.>< errs) + in foldr checkMerge (Map.empty, Seq.empty) merges + +unionunionplusplus :: Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) -> Map NontermIdent (Map ConstructorIdent [a]) +unionunionplusplus = Map.unionWith (Map.unionWith (++)) {-# LINE 273 "src-generated/Transform.hs" #-} {-# LINE 511 "src-ag/Transform.ag" #-} - -mkUniqueRules :: Options -> Map NontermIdent (Map ConstructorIdent [RuleInfo]) -> DataTypes -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Attributes,Attributes) -> NontermIdent -> ConstructorIdent -> Map Identifier Identifier -> [Rule] -mkUniqueRules opts allRules allFields allInsts allAttrDecls nt con usMap - = map apply groups - where - fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allFields) - ++ Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts) - -- may have duplicates - - attrDefs = let projectDefs (_,_,_,defs,_,_,_,_) = defs - in concatMap projectDefs $ Map.findWithDefault [] con $ Map.findWithDefault Map.empty nt allRules - - groups = Map.assocs $ Map.foldrWithKey (\i r m -> Map.insertWith (++) r [i] m) Map.empty usMap - apply (ref,us) = mkRule ref (findOutField ref) us - findOutField ref = case [ chld | (chld, NT tp _ _) <- fields, tp `hasSyn` ref] of - [] -> _LHS - (x:_) -> x - hasSyn tp ref = Map.member ref $ snd $ Map.findWithDefault (Map.empty,Map.empty) tp allAttrDecls - mkRule ref outFld locAttrs - = let locs = filter (not . existsLoc) locAttrs - outAttr = attr outFld ref - defs = (if hasOut then [] else [outAttr]) ++ [attr _LOC u | u <- locs ] - pat = Product noPos defs - rhs = Expression noPos $ wrap ref $ foldr gencase (finalout hasOut locs) locs - -- [HsToken ("mkUniques" ++ show (length locAttrs) ++ " ") noPos, AGField _LHS ref noPos Nothing] - rul = Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False True False Nothing False - hasOut = exists outAttr - exists (Alias fld a _) = (fld,a) `elem` attrDefs - exists _ = False - existsLoc nm = exists (attr _LOC nm) - in rul - attr fld a = Alias fld a (Underscore noPos) - gencase nm outp - = h ("case " ++ uniqueDispenser opts ++ " __cont of { (__cont, " ++ getName nm ++ ") -> ") ++ outp ++ h "}" - h s = [HsToken s noPos] - finalout noGenCont us = h ("(" ++ concat (intersperse "," ( (if noGenCont then [] else ["__cont"]) ++ map getName us)) ++ ")") - wrap ref inp = h "let __cont = " ++ [AGField _LHS ref noPos Nothing] ++ h " in seq __cont ( " ++ inp ++ h " )" + +mkUniqueRules :: Options -> Map NontermIdent (Map ConstructorIdent [RuleInfo]) -> DataTypes -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) -> Map NontermIdent (Attributes,Attributes) -> NontermIdent -> ConstructorIdent -> Map Identifier Identifier -> [Rule] +mkUniqueRules opts allRules allFields allInsts allAttrDecls nt con usMap + = map apply groups + where + fields = Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allFields) + ++ Map.findWithDefault [] con (Map.findWithDefault Map.empty nt allInsts) + -- may have duplicates + + attrDefs = let projectDefs (_,_,_,defs,_,_,_,_) = defs + in concatMap projectDefs $ Map.findWithDefault [] con $ Map.findWithDefault Map.empty nt allRules + + groups = Map.assocs $ Map.foldrWithKey (\i r m -> Map.insertWith (++) r [i] m) Map.empty usMap + apply (ref,us) = mkRule ref (findOutField ref) us + findOutField ref = case [ chld | (chld, NT tp _ _) <- fields, tp `hasSyn` ref] of + [] -> _LHS + (x:_) -> x + hasSyn tp ref = Map.member ref $ snd $ Map.findWithDefault (Map.empty,Map.empty) tp allAttrDecls + mkRule ref outFld locAttrs + = let locs = filter (not . existsLoc) locAttrs + outAttr = attr outFld ref + defs = (if hasOut then [] else [outAttr]) ++ [attr _LOC u | u <- locs ] + pat = Product noPos defs + rhs = Expression noPos $ wrap ref $ foldr gencase (finalout hasOut locs) locs + -- [HsToken ("mkUniques" ++ show (length locAttrs) ++ " ") noPos, AGField _LHS ref noPos Nothing] + rul = Rule Nothing pat rhs False "-- generated by the unique rule mechanism." False True False Nothing False + hasOut = exists outAttr + exists (Alias fld a _) = (fld,a) `elem` attrDefs + exists _ = False + existsLoc nm = exists (attr _LOC nm) + in rul + attr fld a = Alias fld a (Underscore noPos) + gencase nm outp + = h ("case " ++ uniqueDispenser opts ++ " __cont of { (__cont, " ++ getName nm ++ ") -> ") ++ outp ++ h "}" + h s = [HsToken s noPos] + finalout noGenCont us = h ("(" ++ concat (intersperse "," ( (if noGenCont then [] else ["__cont"]) ++ map getName us)) ++ ")") + wrap ref inp = h "let __cont = " ++ [AGField _LHS ref noPos Nothing] ++ h " in seq __cont ( " ++ inp ++ h " )" {-# LINE 313 "src-generated/Transform.hs" #-} {-# LINE 747 "src-ag/Transform.ag" #-} - -flattenDatas :: DataTypes -> Map NontermIdent (Set NontermIdent) -flattenDatas ds = Map.map flatten ds - where flatten cs = Set.fromList [ nt | (_, NT nt _ _) <- concatMap snd (Map.toList cs)] - -reachableFrom :: Map NontermIdent (Set NontermIdent) -> Set NontermIdent -> Set NontermIdent -reachableFrom table = reach - where reach nts = let nts' = Set.unions (nts : [ ns | nt <- Set.toList nts - , let ns = Map.findWithDefault Set.empty nt table ]) - in if Set.size nts' > Set.size nts - then reach nts' - else nts -invert :: Map NontermIdent (Set NontermIdent) -> Map NontermIdent (Set NontermIdent) -invert = foldr inv Map.empty . Map.toList - where inv (x,ns) m = fold (\n m' -> Map.insertWith Set.union n (Set.singleton x) m') m ns - -path :: Map NontermIdent (Set NontermIdent) -> NontermIdent -> NontermIdent -> Set NontermIdent -path table from to = let children = Map.findWithDefault Set.empty from table - forward = reachableFrom table children - backward = reachableFrom (invert table) - (Set.singleton to) - in Set.intersection forward backward + +flattenDatas :: DataTypes -> Map NontermIdent (Set NontermIdent) +flattenDatas ds = Map.map flatten ds + where flatten cs = Set.fromList [ nt | (_, NT nt _ _) <- concatMap snd (Map.toList cs)] + +reachableFrom :: Map NontermIdent (Set NontermIdent) -> Set NontermIdent -> Set NontermIdent +reachableFrom table = reach + where reach nts = let nts' = Set.unions (nts : [ ns | nt <- Set.toList nts + , let ns = Map.findWithDefault Set.empty nt table ]) + in if Set.size nts' > Set.size nts + then reach nts' + else nts +invert :: Map NontermIdent (Set NontermIdent) -> Map NontermIdent (Set NontermIdent) +invert = foldr inv Map.empty . Map.toList + where inv (x,ns) m = fold (\n m' -> Map.insertWith Set.union n (Set.singleton x) m') m ns + +path :: Map NontermIdent (Set NontermIdent) -> NontermIdent -> NontermIdent -> Set NontermIdent +path table from to = let children = Map.findWithDefault Set.empty from table + forward = reachableFrom table children + backward = reachableFrom (invert table) + (Set.singleton to) + in Set.intersection forward backward {-# LINE 338 "src-generated/Transform.hs" #-} {-# LINE 874 "src-ag/Transform.ag" #-} - -extract :: String -> [String] -extract s = case dropWhile isSeparator s of - "" -> [] - s' -> w : extract s'' - where (w, s'') = break isSeparator s' -isSeparator :: Char -> Bool -isSeparator x = x == '_' + +extract :: String -> [String] +extract s = case dropWhile isSeparator s of + "" -> [] + s' -> w : extract s'' + where (w, s'') = break isSeparator s' +isSeparator :: Char -> Bool +isSeparator x = x == '_' {-# LINE 349 "src-generated/Transform.hs" #-} {-# LINE 900 "src-ag/Transform.ag" #-} - -pragmaMapUnion :: PragmaMap -> PragmaMap -> PragmaMap -pragmaMapUnion = Map.unionWith (Map.unionWith Set.union) - -pragmaMapSingle :: NontermIdent -> ConstructorIdent -> Set Identifier -> PragmaMap -pragmaMapSingle nt con nms = Map.singleton nt (Map.singleton con nms) + +pragmaMapUnion :: PragmaMap -> PragmaMap -> PragmaMap +pragmaMapUnion = Map.unionWith (Map.unionWith Set.union) + +pragmaMapSingle :: NontermIdent -> ConstructorIdent -> Set Identifier -> PragmaMap +pragmaMapSingle nt con nms = Map.singleton nt (Map.singleton con nms) {-# LINE 358 "src-generated/Transform.hs" #-} {-# LINE 932 "src-ag/Transform.ag" #-} - -orderMapUnion :: AttrOrderMap -> AttrOrderMap -> AttrOrderMap -orderMapUnion = Map.unionWith (Map.unionWith Set.union) - -orderMapSingle :: NontermIdent -> ConstructorIdent -> Set Dependency -> AttrOrderMap -orderMapSingle nt con deps = Map.singleton nt (Map.singleton con deps) + +orderMapUnion :: AttrOrderMap -> AttrOrderMap -> AttrOrderMap +orderMapUnion = Map.unionWith (Map.unionWith Set.union) + +orderMapSingle :: NontermIdent -> ConstructorIdent -> Set Dependency -> AttrOrderMap +orderMapSingle nt con deps = Map.singleton nt (Map.singleton con deps) {-# LINE 367 "src-generated/Transform.hs" #-} {-# LINE 958 "src-ag/Transform.ag" #-} - -mergeParams :: ParamMap -> ParamMap -> ParamMap -mergeParams = Map.unionWith (++) + +mergeParams :: ParamMap -> ParamMap -> ParamMap +mergeParams = Map.unionWith (++) {-# LINE 373 "src-generated/Transform.hs" #-} {-# LINE 981 "src-ag/Transform.ag" #-} - -mergeCtx :: ContextMap -> ContextMap -> ContextMap -mergeCtx - = Map.unionWith nubconcat - where nubconcat a b = nub (a ++ b) + +mergeCtx :: ContextMap -> ContextMap -> ContextMap +mergeCtx + = Map.unionWith nubconcat + where nubconcat a b = nub (a ++ b) {-# LINE 381 "src-generated/Transform.hs" #-} {-# LINE 1000 "src-ag/Transform.ag" #-} - -mergeQuant :: QuantMap -> QuantMap -> QuantMap -mergeQuant = Map.unionWith (++) + +mergeQuant :: QuantMap -> QuantMap -> QuantMap +mergeQuant = Map.unionWith (++) {-# LINE 387 "src-generated/Transform.hs" #-} {-# LINE 1011 "src-ag/Transform.ag" #-} - -mergeDerivings :: Derivings -> Derivings -> Derivings -mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1) + +mergeDerivings :: Derivings -> Derivings -> Derivings +mergeDerivings m1 m2 = foldr (\(n,cs) m -> Map.insertWith Set.union n cs m) m2 (Map.toList m1) {-# LINE 393 "src-generated/Transform.hs" #-} {-# LINE 1023 "src-ag/Transform.ag" #-} - -merge ::(Ord k, Ord k1) => Map k (Map k1 a) -> Map k (Map k1 a) -> Map k (Map k1 a) -merge x y = foldr f y (Map.toList x) - where f ~(k,v) m = Map.insertWith (Map.union) k v m + +merge ::(Ord k, Ord k1) => Map k (Map k1 a) -> Map k (Map k1 a) -> Map k (Map k1 a) +merge x y = foldr f y (Map.toList x) + where f ~(k,v) m = Map.insertWith (Map.union) k v m {-# LINE 400 "src-generated/Transform.hs" #-} {-# LINE 1066 "src-ag/Transform.ag" #-} - -checkAttrs :: DataTypes -> [NontermIdent] -> [(Identifier, a)] -> [(Identifier, b)] -> Map NontermIdent (Map Identifier a, Map Identifier b) -> (Map NontermIdent (Map Identifier a, Map Identifier b), Seq Error) -checkAttrs allFields nts inherited synthesized decls' = foldErrors check decls' nts where - check nt decls | not (nt `Map.member` allFields) = (decls,Seq.singleton(UndefNont nt)) - | otherwise = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt decls - (inh',einh) = checkDuplicates (DupInhAttr nt) inherited inh - (syn',esyn) = checkDuplicates (DupSynAttr nt) synthesized syn - in (Map.insert nt (inh',syn') decls,einh >< esyn) + +checkAttrs :: DataTypes -> [NontermIdent] -> [(Identifier, a)] -> [(Identifier, b)] -> Map NontermIdent (Map Identifier a, Map Identifier b) -> (Map NontermIdent (Map Identifier a, Map Identifier b), Seq Error) +checkAttrs allFields nts inherited synthesized decls' = foldErrors check decls' nts where + check nt decls | not (nt `Map.member` allFields) = (decls,Seq.singleton(UndefNont nt)) + | otherwise = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt decls + (inh',einh) = checkDuplicates (DupInhAttr nt) inherited inh + (syn',esyn) = checkDuplicates (DupSynAttr nt) synthesized syn + in (Map.insert nt (inh',syn') decls,einh >< esyn) {-# LINE 411 "src-generated/Transform.hs" #-} {-# LINE 1078 "src-ag/Transform.ag" #-} - -addSelf :: Ord k1 => k1 -> Map k1 (Map k a, Attributes) -> Map k1 (Map k a, Attributes) -addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap - in Map.insert name (eInh, Map.insert (Ident "self" noPos) Self eSyn)atMap + +addSelf :: Ord k1 => k1 -> Map k1 (Map k a, Attributes) -> Map k1 (Map k a, Attributes) +addSelf name atMap = let (eInh,eSyn) = Map.findWithDefault(Map.empty,Map.empty) name atMap + in Map.insert name (eInh, Map.insert (Ident "self" noPos) Self eSyn)atMap {-# LINE 418 "src-generated/Transform.hs" #-} {-# LINE 1216 "src-ag/Transform.ag" #-} - --- We want the last Just in the list -flipmplus = flip mplus + +-- We want the last Just in the list +flipmplus = flip mplus {-# LINE 424 "src-generated/Transform.hs" #-} {-# LINE 1224 "src-ag/Transform.ag" #-} - -makeType :: Set NontermIdent -> Type -> Type -makeType nts tp@(NT x _ _) | Set.member x nts = tp - | otherwise = Haskell (typeToHaskellString Nothing [] tp) -makeType _ tp = tp + +makeType :: Set NontermIdent -> Type -> Type +makeType nts tp@(NT x _ _) | Set.member x nts = tp + | otherwise = Haskell (typeToHaskellString Nothing [] tp) +makeType _ tp = tp {-# LINE 432 "src-generated/Transform.hs" #-} {-# LINE 1230 "src-ag/Transform.ag" #-} - -constructGrammar :: Set NontermIdent - -> ParamMap - -> Map NontermIdent (Map ConstructorIdent (Set Identifier)) - -> DataTypes - -> Map NontermIdent [ConstructorIdent] - -> Map NontermIdent (Map ConstructorIdent [Type]) - -> Map NontermIdent (Attributes, Attributes) - -> Map NontermIdent (Map Identifier (String, String, String)) - -> Derivings - -> Set NontermIdent - -> Map NontermIdent (Map ConstructorIdent [Rule]) - -> Map NontermIdent (Map ConstructorIdent [TypeSig]) - -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) - -> TypeSyns - -> PragmaMap - -> AttrOrderMap - -> ContextMap - -> QuantMap - -> UniqueMap - -> Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) - -> Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) - -> Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) - -> Map NontermIdent (Map ConstructorIdent MaybeMacro) - -> Grammar - -constructGrammar _ ntParams prodParams gram prodOrder constraints attrs uses derivings wrap allrules tsigs allinsts tsyns pragmaMap orderMap contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap macros = - let gr = [ (nt,alts) | (nt,alts) <- Map.toList gram] - nonts = map nont gr - nont (nt,alts) = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt attrs - rmap = Map.findWithDefault Map.empty nt allrules - tsmap = Map.findWithDefault Map.empty nt tsigs - instsmap = Map.findWithDefault Map.empty nt allinsts - params = Map.findWithDefault [] nt ntParams - mergemap = Map.findWithDefault Map.empty nt mergeMap - macromap = Map.findWithDefault Map.empty nt macros - csmap = Map.findWithDefault Map.empty nt constraints - psmap = Map.findWithDefault Map.empty nt prodParams - prs = Map.findWithDefault [] nt prodOrder - alt con = - let flds = Map.findWithDefault [] con alts - rules = Map.findWithDefault [] con rmap - tsigs' = Map.findWithDefault [] con tsmap - insts = Map.findWithDefault [] con instsmap - merges = [ (n, NT t [] False) | (n, (t, _, _)) <- Map.assocs $ maybe Map.empty id (Map.lookup con mergemap) ] - cs = Map.findWithDefault [] con csmap - ps = Set.elems $ Map.findWithDefault Set.empty con psmap - mbMacro = Map.findWithDefault Nothing con macromap - - -- important: keep order of children - cldrn = map child (flds ++ filter (not . existsAsField) insts ++ merges) - child (nm, tp) = - let tpI = if existsAsInst nm - then fromJust $ lookup nm insts - else tp - virt = if existsAsInst nm - then case lookup nm flds of - Just tp' -> ChildReplace tp' - Nothing -> ChildAttr - else if existsAsMerge nm - then ChildAttr - else ChildSyntax - in Child nm tpI virt - existsAsInst nm = maybe False (const True) (lookup nm insts) - existsAsField (nm,_) = maybe False (const True) (lookup nm flds) - existsAsMerge nm = maybe False (const True) (lookup nm merges) - in Production con ps cs cldrn rules tsigs' mbMacro - in Nonterminal nt params inh syn (map alt prs) - in Grammar tsyns uses derivings wrap nonts pragmaMap orderMap ntParams contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap + +constructGrammar :: Set NontermIdent + -> ParamMap + -> Map NontermIdent (Map ConstructorIdent (Set Identifier)) + -> DataTypes + -> Map NontermIdent [ConstructorIdent] + -> Map NontermIdent (Map ConstructorIdent [Type]) + -> Map NontermIdent (Attributes, Attributes) + -> Map NontermIdent (Map Identifier (String, String, String)) + -> Derivings + -> Set NontermIdent + -> Map NontermIdent (Map ConstructorIdent [Rule]) + -> Map NontermIdent (Map ConstructorIdent [TypeSig]) + -> Map NontermIdent (Map ConstructorIdent [(Identifier, Type)]) + -> TypeSyns + -> PragmaMap + -> AttrOrderMap + -> ContextMap + -> QuantMap + -> UniqueMap + -> Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) + -> Map NontermIdent (Map ConstructorIdent (Map Identifier [Expression])) + -> Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier], Expression))) + -> Map NontermIdent (Map ConstructorIdent MaybeMacro) + -> Grammar + +constructGrammar _ ntParams prodParams gram prodOrder constraints attrs uses derivings wrap allrules tsigs allinsts tsyns pragmaMap orderMap contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap macros = + let gr = [ (nt,alts) | (nt,alts) <- Map.toList gram] + nonts = map nont gr + nont (nt,alts) = let (inh,syn) = Map.findWithDefault (Map.empty,Map.empty) nt attrs + rmap = Map.findWithDefault Map.empty nt allrules + tsmap = Map.findWithDefault Map.empty nt tsigs + instsmap = Map.findWithDefault Map.empty nt allinsts + params = Map.findWithDefault [] nt ntParams + mergemap = Map.findWithDefault Map.empty nt mergeMap + macromap = Map.findWithDefault Map.empty nt macros + csmap = Map.findWithDefault Map.empty nt constraints + psmap = Map.findWithDefault Map.empty nt prodParams + prs = Map.findWithDefault [] nt prodOrder + alt con = + let flds = Map.findWithDefault [] con alts + rules = Map.findWithDefault [] con rmap + tsigs' = Map.findWithDefault [] con tsmap + insts = Map.findWithDefault [] con instsmap + merges = [ (n, NT t [] False) | (n, (t, _, _)) <- Map.assocs $ maybe Map.empty id (Map.lookup con mergemap) ] + cs = Map.findWithDefault [] con csmap + ps = Set.elems $ Map.findWithDefault Set.empty con psmap + mbMacro = Map.findWithDefault Nothing con macromap + + -- important: keep order of children + cldrn = map child (flds ++ filter (not . existsAsField) insts ++ merges) + child (nm, tp) = + let tpI = if existsAsInst nm + then fromJust $ lookup nm insts + else tp + virt = if existsAsInst nm + then case lookup nm flds of + Just tp' -> ChildReplace tp' + Nothing -> ChildAttr + else if existsAsMerge nm + then ChildAttr + else ChildSyntax + in Child nm tpI virt + existsAsInst nm = maybe False (const True) (lookup nm insts) + existsAsField (nm,_) = maybe False (const True) (lookup nm flds) + existsAsMerge nm = maybe False (const True) (lookup nm merges) + in Production con ps cs cldrn rules tsigs' mbMacro + in Nonterminal nt params inh syn (map alt prs) + in Grammar tsyns uses derivings wrap nonts pragmaMap orderMap ntParams contextMap quantMap uniqueMap augmentsMap aroundsMap mergeMap {-# LINE 504 "src-generated/Transform.hs" #-} {-# LINE 1301 "src-ag/Transform.ag" #-} - -mapUnionWithSetUnion :: Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -mapUnionWithSetUnion = Map.unionWith Set.union -mapUnionWithPlusPlus :: Map BlockInfo [a] -> Map BlockInfo [a] -> Map BlockInfo [a] -mapUnionWithPlusPlus = Map.unionWith (++) + +mapUnionWithSetUnion :: Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) -> Map NontermIdent (Set ConstructorIdent) +mapUnionWithSetUnion = Map.unionWith Set.union +mapUnionWithPlusPlus :: Map BlockInfo [a] -> Map BlockInfo [a] -> Map BlockInfo [a] +mapUnionWithPlusPlus = Map.unionWith (++) {-# LINE 512 "src-generated/Transform.hs" #-} -- AG ---------------------------------------------------------- -- wrapper diff --git a/src-generated/Visage.hs b/src-generated/Visage.hs --- a/src-generated/Visage.hs +++ b/src-generated/Visage.hs @@ -3,66 +3,66 @@ module Visage where {-# LINE 2 "src-ag/Expression.ag" #-} - -import UU.Scanner.Position(Pos) -import HsToken + +import UU.Scanner.Position(Pos) +import HsToken {-# LINE 10 "src-generated/Visage.hs" #-} {-# LINE 2 "src-ag/VisagePatterns.ag" #-} - -import UU.Scanner.Position(Pos) -import CommonTypes + +import UU.Scanner.Position(Pos) +import CommonTypes {-# LINE 16 "src-generated/Visage.hs" #-} {-# LINE 2 "src-ag/VisageSyntax.ag" #-} - -import CommonTypes -import UU.Pretty -import AbstractSyntax -import VisagePatterns -import Expression + +import CommonTypes +import UU.Pretty +import AbstractSyntax +import VisagePatterns +import Expression {-# LINE 25 "src-generated/Visage.hs" #-} {-# LINE 6 "src-ag/Visage.ag" #-} - -import UU.Scanner.Position(Pos(..)) -import CommonTypes -import ATermAbstractSyntax -import Expression -import VisagePatterns -import VisageSyntax -import qualified Data.Map as Map -import Data.Map(Map) -import Data.List(intersperse) -import TokenDef + +import UU.Scanner.Position(Pos(..)) +import CommonTypes +import ATermAbstractSyntax +import Expression +import VisagePatterns +import VisageSyntax +import qualified Data.Map as Map +import Data.Map(Map) +import Data.List(intersperse) +import TokenDef {-# LINE 39 "src-generated/Visage.hs" #-} import Control.Monad.Identity (Identity) import qualified Control.Monad.Identity {-# LINE 19 "src-ag/Visage.ag" #-} - -convert :: String -> String -convert [] = [] -convert (c:ct) | c == '\n' = '\\' : 'n' : convert ct - | otherwise = c : convert ct - -sQ :: String -> String -sQ [] = [] -sQ (x:xs) = if (x=='"') then rest else x:rest - where - rest = if not (null xs) && last xs == '"' then init xs else xs - -showAGPos :: Pos -> String -showAGPos (Pos l c f) | l == (-1) = "" - | otherwise = let file = if null f then "" else f -- No show of f - lc = "(line " ++ show l ++ ", column " ++ show c ++")" - in file ++ lc - -showMap :: (Show a, Show b) => Map a b -> String -showMap - = braces . concat . intersperse "," . map (uncurry assign) . Map.assocs - where - braces s = "{" ++ s ++ "}" - assign a b = show a ++ ":=" ++ show b + +convert :: String -> String +convert [] = [] +convert (c:ct) | c == '\n' = '\\' : 'n' : convert ct + | otherwise = c : convert ct + +sQ :: String -> String +sQ [] = [] +sQ (x:xs) = if (x=='"') then rest else x:rest + where + rest = if not (null xs) && last xs == '"' then init xs else xs + +showAGPos :: Pos -> String +showAGPos (Pos l c f) | l == (-1) = "" + | otherwise = let file = if null f then "" else f -- No show of f + lc = "(line " ++ show l ++ ", column " ++ show c ++")" + in file ++ lc + +showMap :: (Show a, Show b) => Map a b -> String +showMap + = braces . concat . intersperse "," . map (uncurry assign) . Map.assocs + where + braces s = "{" ++ s ++ "}" + assign a b = show a ++ ":=" ++ show b {-# LINE 67 "src-generated/Visage.hs" #-} -- Expression -------------------------------------------------- -- wrapper diff --git a/src-generated/VisagePatterns.hs b/src-generated/VisagePatterns.hs --- a/src-generated/VisagePatterns.hs +++ b/src-generated/VisagePatterns.hs @@ -3,9 +3,9 @@ -- UUAGC 0.9.53 (src-ag/VisagePatterns.ag) module VisagePatterns where {-# LINE 2 "src-ag/VisagePatterns.ag" #-} - -import UU.Scanner.Position(Pos) -import CommonTypes + +import UU.Scanner.Position(Pos) +import CommonTypes {-# LINE 10 "src-generated/VisagePatterns.hs" #-} -- VisagePattern ----------------------------------------------- {- diff --git a/src-generated/VisageSyntax.hs b/src-generated/VisageSyntax.hs --- a/src-generated/VisageSyntax.hs +++ b/src-generated/VisageSyntax.hs @@ -3,12 +3,12 @@ -- UUAGC 0.9.53 (src-ag/VisageSyntax.ag) module VisageSyntax where {-# LINE 2 "src-ag/VisageSyntax.ag" #-} - -import CommonTypes -import UU.Pretty -import AbstractSyntax -import VisagePatterns -import Expression + +import CommonTypes +import UU.Pretty +import AbstractSyntax +import VisagePatterns +import Expression {-# LINE 13 "src-generated/VisageSyntax.hs" #-} -- VisageChild ------------------------------------------------- {- diff --git a/src-main/Main.hs b/src-main/Main.hs --- a/src-main/Main.hs +++ b/src-main/Main.hs @@ -1,6 +1,6 @@ -module Main where - -import UU.UUAGC (uuagcMain) - -main :: IO () +module Main where + +import UU.UUAGC (uuagcMain) + +main :: IO () main = uuagcMain diff --git a/src-options/Options.hs b/src-options/Options.hs --- a/src-options/Options.hs +++ b/src-options/Options.hs @@ -1,553 +1,557 @@ -module Options where - -import System.Console.GetOpt -import Data.Set(Set) -import UU.Scanner.Position(Pos,noPos) -import Data.List(intercalate) -import qualified Data.Set as Set -import System.IO -import System.Exit - --- From CommonTypes -data Identifier = Ident { getName::String, getPos::Pos } -type NontermIdent = Identifier -identifier :: String -> Identifier -identifier x = Ident x noPos - -instance Eq Identifier where - Ident x _ == Ident y _ = x == y - -instance Ord Identifier where - compare (Ident x _) (Ident y _) = compare x y - -instance Show Identifier where - show ident = getName ident - --- Make options serializable -data MyOptDescr = MyOpt [Char] [String] (ArgDescr (Options -> Options)) (Options -> String -> [String]) String - -fromMyOpt :: MyOptDescr -> OptDescr (Options -> Options) -fromMyOpt (MyOpt sh ln desc _ s) = Option sh ln desc s - -noOpt :: Options -> String -> [String] -noOpt _ _ = [] - -boolOpt :: (Options -> Bool) -> Options -> String -> [String] -boolOpt get opt strArg = let oldVal = get noOptions - newVal = get opt - in if oldVal /= newVal - then [strArg] - else [] - -stringOpt :: (Options -> String) -> Options -> String -> [String] -stringOpt get opt strArg = let oldVal = get noOptions - newVal = get opt - in if oldVal /= newVal - then [strArg, newVal] - else [] - -mbStringOpt :: (Options -> Maybe String) -> Options -> String -> [String] -mbStringOpt get opts nm = maybe [] (\s -> [nm++"="++s]) (get opts) - -serializeOption :: Options -> MyOptDescr -> [String] -serializeOption opt (MyOpt sh ln _ get _) = get opt strArg - where - strArg = if null sh - then '-' : '-' : head ln - else '-' : head sh : [] - --- All options -allOptions :: [MyOptDescr] -allOptions = - [ MyOpt ['m'] [] (NoArg (moduleOpt Nothing)) noOpt "generate default module header" - , MyOpt [] ["module"] (OptArg moduleOpt "name") moduleOptGet "generate module header, specify module name" - , MyOpt ['d'] ["data"] (NoArg dataOpt) (boolOpt dataTypes) "generate data type definition" - , MyOpt [] ["datarecords"] (NoArg dataRecOpt) (boolOpt dataRecords) "generate record data types" - , MyOpt [] ["strictdata"] (NoArg strictDataOpt) (boolOpt strictData) "generate strict data fields (when data is generated)" - , MyOpt [] ["strictwrap"] (NoArg strictWrapOpt) (boolOpt strictWrap) "generate strict wrap fields for WRAPPER generated data" - , MyOpt ['c'] ["catas"] (NoArg cataOpt) (boolOpt folds) "generate catamorphisms" - , MyOpt ['f'] ["semfuns"] (NoArg semfunsOpt) (boolOpt semfuns) "generate semantic functions" - , MyOpt ['s'] ["signatures"] (NoArg signaturesOpt) (boolOpt typeSigs) "generate signatures for semantic functions" - , MyOpt [] ["newtypes"] (NoArg newtypesOpt) (boolOpt newtypes) "use newtypes instead of type synonyms" - , MyOpt ['p'] ["pretty"] (NoArg prettyOpt) (boolOpt attrInfo) "generate pretty printed list of attributes" - , MyOpt ['w'] ["wrappers"] (NoArg wrappersOpt) (boolOpt wrappers) "generate wappers for semantic domains" - , MyOpt ['r'] ["rename"] (NoArg renameOpt) (boolOpt rename) "rename data constructors" - , MyOpt [] ["modcopy"] (NoArg modcopyOpt) (boolOpt modcopy) "use modified copy rule" - , MyOpt [] ["nest"] (NoArg nestOpt) (boolOpt nest) "use nested tuples" - , MyOpt [] ["syntaxmacro"] (NoArg smacroOpt) (boolOpt smacro) "experimental: generate syntax macro code (using knit catas)" - , MyOpt ['o'] ["output"] (ReqArg outputOpt "file") outputOptGet "specify output file" - , MyOpt ['v'] ["verbose"] (NoArg verboseOpt) (boolOpt verbose) "verbose error message format" - , MyOpt ['h','?'] ["help"] (NoArg helpOpt) (boolOpt showHelp) "get (this) usage information" - , MyOpt ['a'] ["all"] (NoArg allOpt) noOpt ("do everything (-" ++ allc ++ ")") - , MyOpt ['P'] [""] (ReqArg searchPathOpt "search path") searchPathOptGet ("specify seach path") - , MyOpt [] ["prefix"] (ReqArg prefixOpt "prefix") (stringOpt prefix) "set prefix for semantic functions" - , MyOpt [] ["self"] (NoArg selfOpt) (boolOpt withSelf) "generate self attribute" - , MyOpt [] ["cycle"] (NoArg cycleOpt) (boolOpt withCycle) "check for cyclic definitions" - , MyOpt [] ["version"] (NoArg versionOpt) (boolOpt showVersion) "get version information" - , MyOpt ['O'] ["optimize"] (NoArg optimizeOpt) noOpt "optimize generated code (--visit --case)" - , MyOpt [] ["visit"] (NoArg visitOpt) (boolOpt visit) "try generating visit functions" - , MyOpt [] ["loag"] (OptArg loagOpt "Bool") (boolOpt loag) "recognises all linear ordered attribute grammars by generting a SAT problem, uses --verbose to print out numbers of clauses and variables" - , MyOpt [] ["aoag"] (NoArg aoagOpt) (boolOpt aoag) "recognises all linear ordered attribute grammars by finding fake dependencies, uses --verbose to print out the selected fake dependencies" - , MyOpt [] ["seq"] (NoArg seqOpt) (boolOpt withSeq) "force evaluation using function seq (visit functions only)" - , MyOpt [] ["unbox"] (NoArg unboxOpt) (boolOpt unbox) "use unboxed tuples" - , MyOpt [] ["bangpats"] (NoArg bangpatsOpt) (boolOpt bangpats) "use bang patterns (visit functions only)" - , MyOpt [] ["case"] (NoArg casesOpt) (boolOpt cases) "Use nested cases instead of let (visit functions only)" - , MyOpt [] ["strictcase"] (NoArg strictCasesOpt) (boolOpt strictCases) "Force evaluation of the scrutinee of cases (in generated code, visit functions only)" - , MyOpt [] ["strictercase"] (NoArg stricterCasesOpt) (boolOpt stricterCases) "Force evaluation of all variables bound by a case statement (in generated code)" - , MyOpt [] ["strictsem"] (NoArg strictSemOpt) (boolOpt strictSems) "Force evaluation of sem-function arguments (in generated code)" - , MyOpt [] ["localcps"] (NoArg localCpsOpt) (boolOpt localCps) "Apply a local CPS transformation (in generated code, visit functions only)" - , MyOpt [] ["splitsems"] (NoArg splitSemsOpt) (boolOpt splitSems) "Split semantic functions into smaller pieces" - , MyOpt [] ["Werrors"] (NoArg werrorsOpt) (boolOpt werrors) "Turn warnings into fatal errors" - , MyOpt [] ["Wignore"] (NoArg wignoreOpt) (boolOpt wignore) "Ignore warnings" - , MyOpt [] ["Wmax"] (ReqArg wmaxErrsOpt "") wmaxErrsOptGet "Sets the maximum number of errors that are reported" - , MyOpt [] ["dumpgrammar"] (NoArg dumpgrammarOpt) (boolOpt dumpgrammar) "Dump internal grammar representation (in generated code)" - , MyOpt [] ["dumpcgrammar"] (NoArg dumpcgrammarOpt) (boolOpt dumpcgrammar)"Dump internal cgrammar representation (in generated code)" - , MyOpt [] ["gentraces"] (NoArg genTracesOpt) (boolOpt genTraces) "Generate trace expressions (in generated code)" - , MyOpt [] ["genusetraces"] (NoArg genUseTracesOpt) (boolOpt genUseTraces)"Generate trace expressions at attribute use sites (in generated code)" - , MyOpt [] ["gencostcentres"] (NoArg genCostCentresOpt) (boolOpt genCostCentres) "Generate cost centre pragmas (in generated code)" - , MyOpt [] ["genlinepragmas"] (NoArg genLinePragmasOpt) (boolOpt genLinePragmas) "Generate GHC LINE pragmas (in generated code)" - , MyOpt [] ["sepsemmods"] (NoArg sepSemModsOpt) (boolOpt sepSemMods) "Generate separate modules for semantic functions (in generated code)" - , MyOpt ['M'] ["genfiledeps"] (NoArg genFileDepsOpt) (boolOpt genFileDeps) "Generate a list of dependencies on the input AG files" - , MyOpt [] ["genvisage"] (NoArg genVisageOpt) (boolOpt genvisage) "Generate output for the AG visualizer Visage" - , MyOpt [] ["aspectag"] (NoArg genAspectAGOpt) (boolOpt genAspectAG) "Generate AspectAG file" - , MyOpt [] ["nogroup"] (ReqArg noGroupOpt "attributes") noGroupOptGet "specify the attributes that won't be grouped in AspectAG" - , MyOpt [] ["extends"] (ReqArg extendsOpt "module") (mbStringOpt extends) "specify a module to be extended" - , MyOpt [] ["genattrlist"] (NoArg genAttrListOpt) (boolOpt genAttributeList) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)" - , MyOpt [] ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") (mbStringOpt forceIrrefutables) "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set" - , MyOpt [] ["uniquedispenser"] (ReqArg uniqueDispenserOpt "name") (stringOpt uniqueDispenser) "The Haskell function to call in the generated code" - , MyOpt [] ["lckeywords"] (NoArg lcKeywordsOpt) (boolOpt lcKeywords) "Use lowercase keywords (sem, attr) instead of the uppercase ones (SEM, ATTR)" - , MyOpt [] ["doublecolons"] (NoArg doubleColonsOpt) (boolOpt doubleColons)"Use double colons for type signatures instead of single colons" - , MyOpt ['H'] ["haskellsyntax"] (NoArg haskellSyntaxOpt) noOpt "Use Haskell like syntax (equivalent to --lckeywords and --doublecolons --genlinepragmas)" - , MyOpt [] ["reference"] (NoArg referenceOpt) (boolOpt reference) "Use reference attributes" - , MyOpt [] ["monadic"] (NoArg monadicOpt) (boolOpt monadic) "Experimental: generate monadic code" - , MyOpt [] ["ocaml"] (NoArg ocamlOpt) (boolOpt ocaml) "Generate Ocaml code" - , MyOpt [] ["cleanlang"] (NoArg cleanOpt) (boolOpt clean) "Generate Clean code" - , MyOpt [] ["breadthfirst"] (NoArg breadthfirstOpt) (boolOpt breadthFirst)"Experimental: generate breadth-first code" - , MyOpt [] ["breadthfirst-strict"] (NoArg breadthfirstStrictOpt) (boolOpt breadthFirstStrict) "Experimental: outermost breadth-first evaluator is strict instead of lazy" - , MyOpt [] ["visitcode"] (NoArg visitorsOutputOpt) (boolOpt visitorsOutput) "Experimental: generate visitors code" - , MyOpt [] ["kennedywarren"] (NoArg kennedyWarrenOpt) (boolOpt kennedyWarren) "Use Kennedy-Warren's algorithm for ordering" - , MyOpt [] ["statistics"] (ReqArg statisticsOpt "FILE to append to") (mbStringOpt statsFile) "Append statistics to FILE" - , MyOpt [] ["checkParseRhs"] (NoArg parseHsRhsOpt) (boolOpt checkParseRhs) "Parse RHS of rules with Haskell parser" - , MyOpt [] ["checkParseTys"] (NoArg parseHsTpOpt) (boolOpt checkParseTy) "Parse types of attrs with Haskell parser" - , MyOpt [] ["checkParseBlocks"] (NoArg parseHsBlockOpt) (boolOpt checkParseBlock) "Parse blocks with Haskell parser" - , MyOpt [] ["checkParseHaskell"] (NoArg parseHsOpt) noOpt "Parse Haskell code (recognizer)" - , MyOpt [] ["nocatas"] (ReqArg nocatasOpt "list of nonterms") nocatasOptGet "Nonterminals not to generate catas for" - , MyOpt [] ["nooptimize"] (NoArg noOptimizeOpt) (boolOpt noOptimizations) "Disable optimizations" - , MyOpt [] ["parallel"] (NoArg parallelOpt) (boolOpt parallelInvoke) "Generate a parallel evaluator (if possible)" - , MyOpt [] ["monadicwrapper"] (NoArg monadicWrappersOpt) (boolOpt monadicWrappers) "Generate monadic wrappers" - , MyOpt [] ["helpinlining"] (NoArg helpInliningOpt) (boolOpt helpInlining) "Generate inline directives for GHC" - , MyOpt [] ["dummytokenvisit"] (NoArg dummyTokenVisitOpt) (boolOpt dummyTokenVisit) "Add an additional dummy parameter to visit functions" - , MyOpt [] ["tupleasdummytoken"] (NoArg tupleAsDummyTokenOpt) (boolOpt tupleAsDummyToken) "Use conventional tuples as dummy parameter instead of a RealWorld state token" - , MyOpt [] ["stateasdummytoken"] (NoArg stateAsDummyTokenOpt) noOpt "Use RealWorld state token as dummy parameter instead of conventional tuples (default)" - , MyOpt [] ["strictdummytoken"] (NoArg strictDummyTokenOpt) (boolOpt strictDummyToken) "Strictify the dummy token that makes states and rules functions" - , MyOpt [] ["noperruletypesigs"] (NoArg noPerRuleTypeSigsOpt) (boolOpt noPerRuleTypeSigs) "Do not generate type sigs for attrs passed to rules" - , MyOpt [] ["noperstatetypesigs"] (NoArg noPerStateTypeSigsOpt) (boolOpt noPerStateTypeSigs) "Do not generate type sigs for attrs saved in node states" - , MyOpt [] ["noeagerblackholing"] (NoArg noEagerBlackholingOpt) (boolOpt noEagerBlackholing) "Do not automatically add the eager blackholing feature for parallel programs" - , MyOpt [] ["noperrulecostcentres"] (NoArg noPerRuleCostCentresOpt) (boolOpt noPerRuleCostCentres) "Do not generate cost centres for rules" - , MyOpt [] ["nopervisitcostcentres"] (NoArg noPerVisitCostCentresOpt) (boolOpt noPerVisitCostCentres) "Do not generate cost centres for visits" - , MyOpt [] ["noinlinepragmas"] (NoArg noInlinePragmasOpt) (boolOpt noInlinePragmas) "Definitely not generate inline directives" - , MyOpt [] ["aggressiveinlinepragmas"] (NoArg aggressiveInlinePragmasOpt) (boolOpt aggressiveInlinePragmas) "Generate more aggressive inline directives" - , MyOpt [] ["latehigherorderbinding"] (NoArg lateHigherOrderBindingOpt) (boolOpt lateHigherOrderBinding) "Generate an attribute and wrapper for late binding of higher-order attributes" - , MyOpt [] ["noincludes"] (NoArg noIncludesOpt) (boolOpt noIncludes) "Ignore include directives in .ag files" - , MyOpt [] ["quiet"] (NoArg beQuietOpt) (boolOpt beQuiet) "Dont print some compilation information" - ] - --- For compatibility -options :: [OptDescr (Options -> Options)] -options = map fromMyOpt allOptions - -allc :: String -allc = "dcfsprm" - -data ModuleHeader = NoName - | Name String - | Default deriving (Eq, Show) - -data Options = Options{ moduleName :: ModuleHeader - , dataTypes :: Bool - , dataRecords :: Bool - , strictData :: Bool - , strictWrap :: Bool - , folds :: Bool - , semfuns :: Bool - , typeSigs :: Bool - , attrInfo :: Bool - , rename :: Bool - , wrappers :: Bool - , modcopy :: Bool - , newtypes :: Bool - , nest :: Bool - , smacro :: Bool - , outputFiles :: [String] - , searchPath :: [String] - , verbose :: Bool - , prefix :: String - , withSelf :: Bool - , withCycle :: Bool - , showHelp :: Bool - , showVersion :: Bool - , visit :: Bool - , loag :: Bool - , minvisits :: Bool - , aoag :: Bool - , withSeq :: Bool - , unbox :: Bool - , bangpats :: Bool - , cases :: Bool - , strictCases :: Bool - , stricterCases :: Bool - , strictSems :: Bool - , localCps :: Bool - , splitSems :: Bool - , werrors :: Bool - , wignore :: Bool - , wmaxerrs :: Int - , dumpgrammar :: Bool - , dumpcgrammar :: Bool - , sepSemMods :: Bool - , allowSepSemMods :: Bool - , genFileDeps :: Bool - , genLinePragmas :: Bool - , genvisage :: Bool - , genAspectAG :: Bool - , noGroup :: [String] - , extends :: Maybe String - , genAttributeList :: Bool - , forceIrrefutables :: Maybe String - , uniqueDispenser :: String - , lcKeywords :: Bool - , doubleColons :: Bool - , monadic :: Bool - , ocaml :: Bool - , clean :: Bool - , visitorsOutput :: Bool - , statsFile :: Maybe String - , breadthFirst :: Bool - , breadthFirstStrict :: Bool - , checkParseRhs :: Bool - , checkParseTy :: Bool - , checkParseBlock :: Bool - , nocatas :: Set NontermIdent - , noOptimizations :: Bool - , reference :: Bool - , noIncludes :: Bool - , outputStr :: String -> IO () - , failWithCode :: Int -> IO () - , mainFilename :: Maybe String - , beQuiet :: Bool - - -- KW code path - , kennedyWarren :: Bool - , parallelInvoke :: Bool - , tupleAsDummyToken :: Bool -- use the empty tuple as dummy token instead of State# RealWorld (Lambda State Hack GHC?) - , dummyTokenVisit :: Bool -- add a dummy argument/pass dummy extra token to visits (should not really have an effect ... Lambda State Hack GHC?) - , strictDummyToken :: Bool -- make the dummy token strict (to prevent its removal -- should not really have an effect) - , noPerRuleTypeSigs :: Bool -- do not print type signatures for attributes of rules - , noPerStateTypeSigs :: Bool -- do not print type signatures for attributes contained in the state - , noEagerBlackholing :: Bool -- disable the use of eager black holing in the parallel evaluator code - , lateHigherOrderBinding :: Bool -- generate code to allow late binding of higher-order children semantics - , monadicWrappers :: Bool - - -- tracing - , genTraces :: Bool - , genUseTraces :: Bool - , genCostCentres :: Bool - , noPerRuleCostCentres :: Bool - , noPerVisitCostCentres :: Bool - - -- inline pragma generation - , helpInlining :: Bool - , noInlinePragmas :: Bool - , aggressiveInlinePragmas :: Bool - } -- deriving (Eq, Show) - -noOptions :: Options -noOptions = Options { moduleName = NoName - , dataTypes = False - , dataRecords = False - , strictData = False - , strictWrap = False - , folds = False - , semfuns = False - , typeSigs = False - , attrInfo = False - , rename = False - , wrappers = False - , modcopy = False - , newtypes = False - , nest = False - , smacro = False - , outputFiles = [] - , searchPath = [] - , verbose = False - , showHelp = False - , showVersion = False - , prefix = "sem_" - , withSelf = False - , withCycle = False - , visit = False - , loag = False - , minvisits = False - , aoag = False - , withSeq = False - , unbox = False - , bangpats = False - , cases = False - , strictCases = False - , stricterCases = False - , strictSems = False - , localCps = False - , splitSems = False - , werrors = False - , wignore = False - , wmaxerrs = 99999 - , dumpgrammar = False - , dumpcgrammar = False - , sepSemMods = False - , allowSepSemMods = True - , genFileDeps = False - , genLinePragmas = False - , genvisage = False - , genAspectAG = False - , noGroup = [] - , extends = Nothing - , genAttributeList = False - , forceIrrefutables = Nothing - , uniqueDispenser = "nextUnique" - , lcKeywords = False - , doubleColons = False - , monadic = False - , ocaml = False - , clean = False - , visitorsOutput = False - , statsFile = Nothing - , breadthFirst = False - , breadthFirstStrict = False - , checkParseRhs = False - , checkParseTy = False - , checkParseBlock = False - , nocatas = Set.empty - , noOptimizations = False - , reference = False - , noIncludes = False - , outputStr = hPutStr stderr - , failWithCode = exitWith . ExitFailure - , mainFilename = Nothing - , beQuiet = False - - -- defaults for the KW-code path - , kennedyWarren = False - , parallelInvoke = False - , tupleAsDummyToken = True - , dummyTokenVisit = False - , strictDummyToken = False - , noPerRuleTypeSigs = False - , noPerStateTypeSigs = False - , noEagerBlackholing = False - , lateHigherOrderBinding = False - , monadicWrappers = False - - -- defaults for tracing - , genTraces = False - , genUseTraces = False - , genCostCentres = False - , noPerRuleCostCentres = False - , noPerVisitCostCentres = False - - -- defaults for inline pragma generation - , helpInlining = False - , noInlinePragmas = False - , aggressiveInlinePragmas = False - } - -loagOpt :: (Maybe String) -> Options -> Options -loagOpt mstr opts = - case mstr of - Nothing -> opts' - Just "0" -> opts' - Just _ -> opts' {minvisits = True} - - where opts'=opts{loag = True, visit = True} - -aoagOpt :: Options -> Options -aoagOpt opts = - opts{loag = True, visit = True, aoag = True} - ---Options -> String -> [String] -moduleOpt :: Maybe String -> Options -> Options -moduleOpt nm opts = opts{moduleName = maybe Default Name nm} -moduleOptGet :: Options -> String -> [String] -moduleOptGet opts nm = case moduleName opts of - NoName -> [] - Name s -> [nm++"="++s] - Default -> [nm] - -dataOpt, dataRecOpt, strictDataOpt, strictWrapOpt, cataOpt, semfunsOpt, signaturesOpt, prettyOpt,renameOpt, wrappersOpt, modcopyOpt, newtypesOpt, nestOpt, smacroOpt, verboseOpt, helpOpt, versionOpt, selfOpt, cycleOpt, visitOpt, seqOpt, unboxOpt, bangpatsOpt, casesOpt, strictCasesOpt, stricterCasesOpt, strictSemOpt, localCpsOpt, splitSemsOpt, werrorsOpt, wignoreOpt, dumpgrammarOpt, dumpcgrammarOpt, genTracesOpt, genUseTracesOpt, genCostCentresOpt, sepSemModsOpt, genFileDepsOpt, genLinePragmasOpt, genVisageOpt, genAspectAGOpt, dummyTokenVisitOpt, tupleAsDummyTokenOpt, stateAsDummyTokenOpt, strictDummyTokenOpt, noPerRuleTypeSigsOpt, noPerStateTypeSigsOpt, noEagerBlackholingOpt, noPerRuleCostCentresOpt, noPerVisitCostCentresOpt, helpInliningOpt, noInlinePragmasOpt, aggressiveInlinePragmasOpt, lateHigherOrderBindingOpt, monadicWrappersOpt, referenceOpt, genAttrListOpt, lcKeywordsOpt, doubleColonsOpt, haskellSyntaxOpt, monadicOpt, parallelOpt, ocamlOpt, cleanOpt, visitorsOutputOpt, breadthfirstOpt, breadthfirstStrictOpt, parseHsRhsOpt, parseHsTpOpt, parseHsBlockOpt, parseHsOpt, kennedyWarrenOpt, noOptimizeOpt, allOpt, optimizeOpt, noIncludesOpt, beQuietOpt, condDisableOptimizations :: Options -> Options - -dataOpt opts = opts{dataTypes = True} -dataRecOpt opts = opts{dataRecords = True} -strictDataOpt opts = opts{strictData = True} -strictWrapOpt opts = opts{strictWrap = True} -cataOpt opts = opts{folds = True} -semfunsOpt opts = opts{semfuns = True} -signaturesOpt opts = opts{typeSigs = True} -prettyOpt opts = opts{attrInfo = True} -renameOpt opts = opts{rename = True} -wrappersOpt opts = opts{wrappers = True} -modcopyOpt opts = opts{modcopy = True} -newtypesOpt opts = opts{newtypes = True} -nestOpt opts = opts{nest = True} -smacroOpt opts = opts{smacro = True} -verboseOpt opts = opts{verbose = True} -helpOpt opts = opts{showHelp = True} -versionOpt opts = opts{showVersion = True} -prefixOpt :: String -> Options -> Options -prefixOpt pre opts = opts{prefix = pre } -selfOpt opts = opts{withSelf = True} -cycleOpt opts = opts{withCycle = True} -visitOpt opts = opts{visit = True, withCycle = True} -seqOpt opts = opts{withSeq = True} -unboxOpt opts = opts{unbox = True} -bangpatsOpt opts = opts{bangpats = True} -casesOpt opts = opts{cases = True} -strictCasesOpt opts = opts{strictCases = True} -stricterCasesOpt opts = opts{strictCases = True, stricterCases = True} -strictSemOpt opts = opts{strictSems = True} -localCpsOpt opts = opts{localCps = True} -splitSemsOpt opts = opts{splitSems = True} -werrorsOpt opts = opts{werrors = True} -wignoreOpt opts = opts{wignore = True} -wmaxErrsOpt :: String -> Options -> Options -wmaxErrsOpt n opts = opts{wmaxerrs = read n} -wmaxErrsOptGet :: Options -> String -> [String] -wmaxErrsOptGet opts nm = if wmaxerrs opts /= wmaxerrs noOptions - then [nm,show (wmaxerrs opts)] - else [] -dumpgrammarOpt opts = opts{dumpgrammar = True} -dumpcgrammarOpt opts = opts{dumpcgrammar = True} -genTracesOpt opts = opts{genTraces = True} -genUseTracesOpt opts = opts{genUseTraces = True} -genCostCentresOpt opts = opts{genCostCentres = True} -sepSemModsOpt opts = opts{sepSemMods = allowSepSemMods opts} -genFileDepsOpt opts = opts{genFileDeps = True} -genLinePragmasOpt opts = opts{genLinePragmas = True} -genVisageOpt opts = opts{genvisage = True } -genAspectAGOpt opts = opts{genAspectAG = True} - -dummyTokenVisitOpt opts = opts { dummyTokenVisit = True } -tupleAsDummyTokenOpt opts = opts { tupleAsDummyToken = True } -stateAsDummyTokenOpt opts = opts { tupleAsDummyToken = False } -strictDummyTokenOpt opts = opts { strictDummyToken = True } -noPerRuleTypeSigsOpt opts = opts { noPerRuleTypeSigs = True } -noPerStateTypeSigsOpt opts = opts { noPerStateTypeSigs = True } -noEagerBlackholingOpt opts = opts { noEagerBlackholing = True } -noPerRuleCostCentresOpt opts = opts { noPerRuleCostCentres = True } -noPerVisitCostCentresOpt opts = opts { noPerVisitCostCentres = True } -helpInliningOpt opts = opts { helpInlining = True } -noInlinePragmasOpt opts = opts { noInlinePragmas = True } -aggressiveInlinePragmasOpt opts = opts { aggressiveInlinePragmas = True } -lateHigherOrderBindingOpt opts = opts { lateHigherOrderBinding = True } -monadicWrappersOpt opts = opts { monadicWrappers = True } -referenceOpt opts = opts { reference = True } - -noGroupOpt :: String -> Options -> Options -noGroupOpt att opts = opts{noGroup = wordsBy (== ':') att ++ noGroup opts} -noGroupOptGet :: Options -> String -> [String] -noGroupOptGet opts nm = if null (noGroup opts) - then [] - else [nm, intercalate ":" (noGroup opts)] -extendsOpt :: String -> Options -> Options -extendsOpt m opts = opts{extends = Just m } - -genAttrListOpt opts = opts { genAttributeList = True } -forceIrrefutableOpt :: Maybe String -> Options -> Options -forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm } -uniqueDispenserOpt :: String -> Options -> Options -uniqueDispenserOpt nm opts = opts { uniqueDispenser = nm } -lcKeywordsOpt opts = opts { lcKeywords = True } -doubleColonsOpt opts = opts { doubleColons = True } -haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt -monadicOpt opts = opts { monadic = True } -parallelOpt opts = opts { parallelInvoke = True } -ocamlOpt opts = opts { ocaml = True, kennedyWarren = True, withCycle = True, visit = True } -cleanOpt opts = opts { clean = True } --TODO: More? -visitorsOutputOpt opts = opts { visitorsOutput = True } -statisticsOpt :: String -> Options -> Options -statisticsOpt nm opts = opts { statsFile = Just nm } -breadthfirstOpt opts = opts { breadthFirst = True } -breadthfirstStrictOpt opts = opts { breadthFirstStrict = True } -parseHsRhsOpt opts = opts { checkParseRhs = True } -parseHsTpOpt opts = opts { checkParseTy = True } -parseHsBlockOpt opts = opts { checkParseBlock = True } -parseHsOpt = parseHsRhsOpt . parseHsTpOpt . parseHsBlockOpt -kennedyWarrenOpt opts = opts { kennedyWarren = True } -noOptimizeOpt opts = opts { noOptimizations = True } -nocatasOpt :: String -> Options -> Options -nocatasOpt str opts = opts { nocatas = set `Set.union` nocatas opts } where - set = Set.fromList ids - ids = map identifier lst - lst = wordsBy (== ',') str -nocatasOptGet :: Options -> String -> [String] -nocatasOptGet opts nm = if Set.null (nocatas opts) - then [] - else [nm,intercalate "," . map getName . Set.toList . nocatas $ opts] -outputOpt :: String -> Options -> Options -outputOpt file opts = opts{outputFiles = file : outputFiles opts} -outputOptGet :: Options -> String -> [String] -outputOptGet opts nm = concat [ [nm, file] | file <- outputFiles opts] -searchPathOpt :: String -> Options -> Options -searchPathOpt path opts = opts{searchPath = wordsBy (\x -> x == ';' || x == ':') path ++ searchPath opts} -searchPathOptGet :: Options -> String -> [String] -searchPathOptGet opts nm = if null (searchPath opts) - then [] - else [nm, intercalate ":" (searchPath opts)] -allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt . dataRecOpt -optimizeOpt = visitOpt . casesOpt -noIncludesOpt opts = opts { noIncludes = True } -beQuietOpt opts = opts { beQuiet = True } - -condDisableOptimizations opts - | noOptimizations opts = - opts { strictData = False - , strictWrap = False - , withSeq = False - , unbox = False - , bangpats = False - , cases = False - , strictCases = False - , stricterCases = False - , strictSems = False - , localCps = False - , splitSems = False - , breadthFirstStrict = False - } - | otherwise = opts - --- | Inverse of intercalate -wordsBy :: (Char -> Bool) -> String -> [String] -wordsBy p = f - where - f s = let (x,xs) = break p s - in if null x then [] else x : f (drop 1 xs) - --- | Use all parsed options to generate real options -constructOptions :: [Options -> Options] -> Options -constructOptions = foldl (flip ($)) noOptions - --- | Create Options type from string arguments -getOptions :: [String] -> (Options,[String],[String]) -getOptions args = let (flags,files,errors) = getOpt Permute options args - appliedOpts = constructOptions flags - finOpts = condDisableOptimizations appliedOpts - in (finOpts,files,errors) - --- | Convert options back to commandline string -optionsToString :: Options -> [String] -optionsToString opt = concatMap (serializeOption opt) allOptions - --- | Combine 2 sets of options -combineOptions :: Options -> Options -> Options -combineOptions o1 o2 = let str1 = optionsToString o1 - str2 = optionsToString o2 - (opt,_,_) = getOptions (str1 ++ str2) - in opt +module Options where + +import System.Console.GetOpt +import Data.Set(Set) +import UU.Scanner.Position(Pos,noPos) +import Data.List(intercalate) +import qualified Data.Set as Set +import System.IO +import System.Exit + +-- From CommonTypes +data Identifier = Ident { getName::String, getPos::Pos } +type NontermIdent = Identifier +identifier :: String -> Identifier +identifier x = Ident x noPos + +instance Eq Identifier where + Ident x _ == Ident y _ = x == y + +instance Ord Identifier where + compare (Ident x _) (Ident y _) = compare x y + +instance Show Identifier where + show ident = getName ident + +-- Make options serializable +data MyOptDescr = MyOpt [Char] [String] (ArgDescr (Options -> Options)) (Options -> String -> [String]) String + +fromMyOpt :: MyOptDescr -> OptDescr (Options -> Options) +fromMyOpt (MyOpt sh ln desc _ s) = Option sh ln desc s + +noOpt :: Options -> String -> [String] +noOpt _ _ = [] + +boolOpt :: (Options -> Bool) -> Options -> String -> [String] +boolOpt get opt strArg = let oldVal = get noOptions + newVal = get opt + in if oldVal /= newVal + then [strArg] + else [] + +stringOpt :: (Options -> String) -> Options -> String -> [String] +stringOpt get opt strArg = let oldVal = get noOptions + newVal = get opt + in if oldVal /= newVal + then [strArg, newVal] + else [] + +mbStringOpt :: (Options -> Maybe String) -> Options -> String -> [String] +mbStringOpt get opts nm = maybe [] (\s -> [nm++"="++s]) (get opts) + +serializeOption :: Options -> MyOptDescr -> [String] +serializeOption opt (MyOpt sh ln _ get _) = get opt strArg + where + strArg = if null sh + then '-' : '-' : head ln + else '-' : head sh : [] + +-- All options +allOptions :: [MyOptDescr] +allOptions = + [ MyOpt ['m'] [] (NoArg (moduleOpt Nothing)) noOpt "generate default module header" + , MyOpt [] ["module"] (OptArg moduleOpt "name") moduleOptGet "generate module header, specify module name" + , MyOpt ['d'] ["data"] (NoArg dataOpt) (boolOpt dataTypes) "generate data type definition" + , MyOpt [] ["datarecords"] (NoArg dataRecOpt) (boolOpt dataRecords) "generate record data types" + , MyOpt [] ["strictdata"] (NoArg strictDataOpt) (boolOpt strictData) "generate strict data fields (when data is generated)" + , MyOpt [] ["strictwrap"] (NoArg strictWrapOpt) (boolOpt strictWrap) "generate strict wrap fields for WRAPPER generated data" + , MyOpt ['c'] ["catas"] (NoArg cataOpt) (boolOpt folds) "generate catamorphisms" + , MyOpt ['f'] ["semfuns"] (NoArg semfunsOpt) (boolOpt semfuns) "generate semantic functions" + , MyOpt ['s'] ["signatures"] (NoArg signaturesOpt) (boolOpt typeSigs) "generate signatures for semantic functions" + , MyOpt [] ["newtypes"] (NoArg newtypesOpt) (boolOpt newtypes) "use newtypes instead of type synonyms" + , MyOpt ['p'] ["pretty"] (NoArg prettyOpt) (boolOpt attrInfo) "generate pretty printed list of attributes" + , MyOpt ['w'] ["wrappers"] (NoArg wrappersOpt) (boolOpt wrappers) "generate wappers for semantic domains" + , MyOpt ['r'] ["rename"] (NoArg renameOpt) (boolOpt rename) "rename data constructors" + , MyOpt [] ["modcopy"] (NoArg modcopyOpt) (boolOpt modcopy) "use modified copy rule" + , MyOpt [] ["nest"] (NoArg nestOpt) (boolOpt nest) "use nested tuples" + , MyOpt [] ["syntaxmacro"] (NoArg smacroOpt) (boolOpt smacro) "experimental: generate syntax macro code (using knit catas)" + , MyOpt ['o'] ["output"] (ReqArg outputOpt "file") outputOptGet "specify output file" + , MyOpt ['v'] ["verbose"] (NoArg verboseOpt) (boolOpt verbose) "verbose error message format" + , MyOpt ['h','?'] ["help"] (NoArg helpOpt) (boolOpt showHelp) "get (this) usage information" + , MyOpt ['a'] ["all"] (NoArg allOpt) noOpt ("do everything (-" ++ allc ++ ")") + , MyOpt ['P'] [""] (ReqArg searchPathOpt "search path") searchPathOptGet ("specify seach path") + , MyOpt [] ["prefix"] (ReqArg prefixOpt "prefix") (stringOpt prefix) "set prefix for semantic functions" + , MyOpt [] ["self"] (NoArg selfOpt) (boolOpt withSelf) "generate self attribute" + , MyOpt [] ["cycle"] (NoArg cycleOpt) (boolOpt withCycle) "check for cyclic definitions" + , MyOpt [] ["version"] (NoArg versionOpt) (boolOpt showVersion) "get version information" + , MyOpt ['O'] ["optimize"] (NoArg optimizeOpt) noOpt "optimize generated code (--visit --case)" + , MyOpt [] ["visit"] (NoArg visitOpt) (boolOpt visit) "try generating visit functions" + , MyOpt [] ["loag"] (OptArg loagOpt "Bool") (boolOpt loag) "recognises all linear ordered attribute grammars by generting a SAT problem, uses --verbose to print out numbers of clauses and variables" + , MyOpt [] ["aoag"] (NoArg aoagOpt) (boolOpt aoag) "recognises all linear ordered attribute grammars by finding fake dependencies, uses --verbose to print out the selected fake dependencies" + , MyOpt [] ["seq"] (NoArg seqOpt) (boolOpt withSeq) "force evaluation using function seq (visit functions only)" + , MyOpt [] ["unbox"] (NoArg unboxOpt) (boolOpt unbox) "use unboxed tuples" + , MyOpt [] ["bangpats"] (NoArg bangpatsOpt) (boolOpt bangpats) "use bang patterns (visit functions only)" + , MyOpt [] ["case"] (NoArg casesOpt) (boolOpt cases) "Use nested cases instead of let (visit functions only)" + , MyOpt [] ["strictcase"] (NoArg strictCasesOpt) (boolOpt strictCases) "Force evaluation of the scrutinee of cases (in generated code, visit functions only)" + , MyOpt [] ["strictercase"] (NoArg stricterCasesOpt) (boolOpt stricterCases) "Force evaluation of all variables bound by a case statement (in generated code)" + , MyOpt [] ["strictsem"] (NoArg strictSemOpt) (boolOpt strictSems) "Force evaluation of sem-function arguments (in generated code)" + , MyOpt [] ["localcps"] (NoArg localCpsOpt) (boolOpt localCps) "Apply a local CPS transformation (in generated code, visit functions only)" + , MyOpt [] ["splitsems"] (NoArg splitSemsOpt) (boolOpt splitSems) "Split semantic functions into smaller pieces" + , MyOpt [] ["Werrors"] (NoArg werrorsOpt) (boolOpt werrors) "Turn warnings into fatal errors" + , MyOpt [] ["Wignore"] (NoArg wignoreOpt) (boolOpt wignore) "Ignore warnings" + , MyOpt [] ["Wmax"] (ReqArg wmaxErrsOpt "") wmaxErrsOptGet "Sets the maximum number of errors that are reported" + , MyOpt [] ["dumpgrammar"] (NoArg dumpgrammarOpt) (boolOpt dumpgrammar) "Dump internal grammar representation (in generated code)" + , MyOpt [] ["dumpcgrammar"] (NoArg dumpcgrammarOpt) (boolOpt dumpcgrammar)"Dump internal cgrammar representation (in generated code)" + , MyOpt [] ["gentraces"] (NoArg genTracesOpt) (boolOpt genTraces) "Generate trace expressions (in generated code)" + , MyOpt [] ["genusetraces"] (NoArg genUseTracesOpt) (boolOpt genUseTraces)"Generate trace expressions at attribute use sites (in generated code)" + , MyOpt [] ["gencostcentres"] (NoArg genCostCentresOpt) (boolOpt genCostCentres) "Generate cost centre pragmas (in generated code)" + , MyOpt [] ["genlinepragmas"] (NoArg genLinePragmasOpt) (boolOpt genLinePragmas) "Generate GHC LINE pragmas (in generated code)" + , MyOpt [] ["sepsemmods"] (NoArg sepSemModsOpt) (boolOpt sepSemMods) "Generate separate modules for semantic functions (in generated code)" + , MyOpt ['M'] ["genfiledeps"] (NoArg genFileDepsOpt) (boolOpt genFileDeps) "Generate a list of dependencies on the input AG files" + , MyOpt [] ["genvisage"] (NoArg genVisageOpt) (boolOpt genvisage) "Generate output for the AG visualizer Visage" + , MyOpt [] ["genmirage"] (NoArg genMirageOpt) (boolOpt genmirage) "Generate output for the AG visualizer Mirage" + , MyOpt [] ["aspectag"] (NoArg genAspectAGOpt) (boolOpt genAspectAG) "Generate AspectAG file" + , MyOpt [] ["nogroup"] (ReqArg noGroupOpt "attributes") noGroupOptGet "specify the attributes that won't be grouped in AspectAG" + , MyOpt [] ["extends"] (ReqArg extendsOpt "module") (mbStringOpt extends) "specify a module to be extended" + , MyOpt [] ["genattrlist"] (NoArg genAttrListOpt) (boolOpt genAttributeList) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)" + , MyOpt [] ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") (mbStringOpt forceIrrefutables) "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set" + , MyOpt [] ["uniquedispenser"] (ReqArg uniqueDispenserOpt "name") (stringOpt uniqueDispenser) "The Haskell function to call in the generated code" + , MyOpt [] ["lckeywords"] (NoArg lcKeywordsOpt) (boolOpt lcKeywords) "Use lowercase keywords (sem, attr) instead of the uppercase ones (SEM, ATTR)" + , MyOpt [] ["doublecolons"] (NoArg doubleColonsOpt) (boolOpt doubleColons)"Use double colons for type signatures instead of single colons" + , MyOpt ['H'] ["haskellsyntax"] (NoArg haskellSyntaxOpt) noOpt "Use Haskell like syntax (equivalent to --lckeywords and --doublecolons --genlinepragmas)" + , MyOpt [] ["reference"] (NoArg referenceOpt) (boolOpt reference) "Use reference attributes" + , MyOpt [] ["monadic"] (NoArg monadicOpt) (boolOpt monadic) "Experimental: generate monadic code" + , MyOpt [] ["ocaml"] (NoArg ocamlOpt) (boolOpt ocaml) "Generate Ocaml code" + , MyOpt [] ["cleanlang"] (NoArg cleanOpt) (boolOpt clean) "Generate Clean code" + , MyOpt [] ["breadthfirst"] (NoArg breadthfirstOpt) (boolOpt breadthFirst)"Experimental: generate breadth-first code" + , MyOpt [] ["breadthfirst-strict"] (NoArg breadthfirstStrictOpt) (boolOpt breadthFirstStrict) "Experimental: outermost breadth-first evaluator is strict instead of lazy" + , MyOpt [] ["visitcode"] (NoArg visitorsOutputOpt) (boolOpt visitorsOutput) "Experimental: generate visitors code" + , MyOpt [] ["kennedywarren"] (NoArg kennedyWarrenOpt) (boolOpt kennedyWarren) "Use Kennedy-Warren's algorithm for ordering" + , MyOpt [] ["statistics"] (ReqArg statisticsOpt "FILE to append to") (mbStringOpt statsFile) "Append statistics to FILE" + , MyOpt [] ["checkParseRhs"] (NoArg parseHsRhsOpt) (boolOpt checkParseRhs) "Parse RHS of rules with Haskell parser" + , MyOpt [] ["checkParseTys"] (NoArg parseHsTpOpt) (boolOpt checkParseTy) "Parse types of attrs with Haskell parser" + , MyOpt [] ["checkParseBlocks"] (NoArg parseHsBlockOpt) (boolOpt checkParseBlock) "Parse blocks with Haskell parser" + , MyOpt [] ["checkParseHaskell"] (NoArg parseHsOpt) noOpt "Parse Haskell code (recognizer)" + , MyOpt [] ["nocatas"] (ReqArg nocatasOpt "list of nonterms") nocatasOptGet "Nonterminals not to generate catas for" + , MyOpt [] ["nooptimize"] (NoArg noOptimizeOpt) (boolOpt noOptimizations) "Disable optimizations" + , MyOpt [] ["parallel"] (NoArg parallelOpt) (boolOpt parallelInvoke) "Generate a parallel evaluator (if possible)" + , MyOpt [] ["monadicwrapper"] (NoArg monadicWrappersOpt) (boolOpt monadicWrappers) "Generate monadic wrappers" + , MyOpt [] ["helpinlining"] (NoArg helpInliningOpt) (boolOpt helpInlining) "Generate inline directives for GHC" + , MyOpt [] ["dummytokenvisit"] (NoArg dummyTokenVisitOpt) (boolOpt dummyTokenVisit) "Add an additional dummy parameter to visit functions" + , MyOpt [] ["tupleasdummytoken"] (NoArg tupleAsDummyTokenOpt) (boolOpt tupleAsDummyToken) "Use conventional tuples as dummy parameter instead of a RealWorld state token" + , MyOpt [] ["stateasdummytoken"] (NoArg stateAsDummyTokenOpt) noOpt "Use RealWorld state token as dummy parameter instead of conventional tuples (default)" + , MyOpt [] ["strictdummytoken"] (NoArg strictDummyTokenOpt) (boolOpt strictDummyToken) "Strictify the dummy token that makes states and rules functions" + , MyOpt [] ["noperruletypesigs"] (NoArg noPerRuleTypeSigsOpt) (boolOpt noPerRuleTypeSigs) "Do not generate type sigs for attrs passed to rules" + , MyOpt [] ["noperstatetypesigs"] (NoArg noPerStateTypeSigsOpt) (boolOpt noPerStateTypeSigs) "Do not generate type sigs for attrs saved in node states" + , MyOpt [] ["noeagerblackholing"] (NoArg noEagerBlackholingOpt) (boolOpt noEagerBlackholing) "Do not automatically add the eager blackholing feature for parallel programs" + , MyOpt [] ["noperrulecostcentres"] (NoArg noPerRuleCostCentresOpt) (boolOpt noPerRuleCostCentres) "Do not generate cost centres for rules" + , MyOpt [] ["nopervisitcostcentres"] (NoArg noPerVisitCostCentresOpt) (boolOpt noPerVisitCostCentres) "Do not generate cost centres for visits" + , MyOpt [] ["noinlinepragmas"] (NoArg noInlinePragmasOpt) (boolOpt noInlinePragmas) "Definitely not generate inline directives" + , MyOpt [] ["aggressiveinlinepragmas"] (NoArg aggressiveInlinePragmasOpt) (boolOpt aggressiveInlinePragmas) "Generate more aggressive inline directives" + , MyOpt [] ["latehigherorderbinding"] (NoArg lateHigherOrderBindingOpt) (boolOpt lateHigherOrderBinding) "Generate an attribute and wrapper for late binding of higher-order attributes" + , MyOpt [] ["noincludes"] (NoArg noIncludesOpt) (boolOpt noIncludes) "Ignore include directives in .ag files" + , MyOpt [] ["quiet"] (NoArg beQuietOpt) (boolOpt beQuiet) "Dont print some compilation information" + ] + +-- For compatibility +options :: [OptDescr (Options -> Options)] +options = map fromMyOpt allOptions + +allc :: String +allc = "dcfsprm" + +data ModuleHeader = NoName + | Name String + | Default deriving (Eq, Show) + +data Options = Options{ moduleName :: ModuleHeader + , dataTypes :: Bool + , dataRecords :: Bool + , strictData :: Bool + , strictWrap :: Bool + , folds :: Bool + , semfuns :: Bool + , typeSigs :: Bool + , attrInfo :: Bool + , rename :: Bool + , wrappers :: Bool + , modcopy :: Bool + , newtypes :: Bool + , nest :: Bool + , smacro :: Bool + , outputFiles :: [String] + , searchPath :: [String] + , verbose :: Bool + , prefix :: String + , withSelf :: Bool + , withCycle :: Bool + , showHelp :: Bool + , showVersion :: Bool + , visit :: Bool + , loag :: Bool + , minvisits :: Bool + , aoag :: Bool + , withSeq :: Bool + , unbox :: Bool + , bangpats :: Bool + , cases :: Bool + , strictCases :: Bool + , stricterCases :: Bool + , strictSems :: Bool + , localCps :: Bool + , splitSems :: Bool + , werrors :: Bool + , wignore :: Bool + , wmaxerrs :: Int + , dumpgrammar :: Bool + , dumpcgrammar :: Bool + , sepSemMods :: Bool + , allowSepSemMods :: Bool + , genFileDeps :: Bool + , genLinePragmas :: Bool + , genvisage :: Bool + , genmirage :: Bool + , genAspectAG :: Bool + , noGroup :: [String] + , extends :: Maybe String + , genAttributeList :: Bool + , forceIrrefutables :: Maybe String + , uniqueDispenser :: String + , lcKeywords :: Bool + , doubleColons :: Bool + , monadic :: Bool + , ocaml :: Bool + , clean :: Bool + , visitorsOutput :: Bool + , statsFile :: Maybe String + , breadthFirst :: Bool + , breadthFirstStrict :: Bool + , checkParseRhs :: Bool + , checkParseTy :: Bool + , checkParseBlock :: Bool + , nocatas :: Set NontermIdent + , noOptimizations :: Bool + , reference :: Bool + , noIncludes :: Bool + , outputStr :: String -> IO () + , failWithCode :: Int -> IO () + , mainFilename :: Maybe String + , beQuiet :: Bool + + -- KW code path + , kennedyWarren :: Bool + , parallelInvoke :: Bool + , tupleAsDummyToken :: Bool -- use the empty tuple as dummy token instead of State# RealWorld (Lambda State Hack GHC?) + , dummyTokenVisit :: Bool -- add a dummy argument/pass dummy extra token to visits (should not really have an effect ... Lambda State Hack GHC?) + , strictDummyToken :: Bool -- make the dummy token strict (to prevent its removal -- should not really have an effect) + , noPerRuleTypeSigs :: Bool -- do not print type signatures for attributes of rules + , noPerStateTypeSigs :: Bool -- do not print type signatures for attributes contained in the state + , noEagerBlackholing :: Bool -- disable the use of eager black holing in the parallel evaluator code + , lateHigherOrderBinding :: Bool -- generate code to allow late binding of higher-order children semantics + , monadicWrappers :: Bool + + -- tracing + , genTraces :: Bool + , genUseTraces :: Bool + , genCostCentres :: Bool + , noPerRuleCostCentres :: Bool + , noPerVisitCostCentres :: Bool + + -- inline pragma generation + , helpInlining :: Bool + , noInlinePragmas :: Bool + , aggressiveInlinePragmas :: Bool + } -- deriving (Eq, Show) + +noOptions :: Options +noOptions = Options { moduleName = NoName + , dataTypes = False + , dataRecords = False + , strictData = False + , strictWrap = False + , folds = False + , semfuns = False + , typeSigs = False + , attrInfo = False + , rename = False + , wrappers = False + , modcopy = False + , newtypes = False + , nest = False + , smacro = False + , outputFiles = [] + , searchPath = [] + , verbose = False + , showHelp = False + , showVersion = False + , prefix = "sem_" + , withSelf = False + , withCycle = False + , visit = False + , loag = False + , minvisits = False + , aoag = False + , withSeq = False + , unbox = False + , bangpats = False + , cases = False + , strictCases = False + , stricterCases = False + , strictSems = False + , localCps = False + , splitSems = False + , werrors = False + , wignore = False + , wmaxerrs = 99999 + , dumpgrammar = False + , dumpcgrammar = False + , sepSemMods = False + , allowSepSemMods = True + , genFileDeps = False + , genLinePragmas = False + , genvisage = False + , genmirage = False + , genAspectAG = False + , noGroup = [] + , extends = Nothing + , genAttributeList = False + , forceIrrefutables = Nothing + , uniqueDispenser = "nextUnique" + , lcKeywords = False + , doubleColons = False + , monadic = False + , ocaml = False + , clean = False + , visitorsOutput = False + , statsFile = Nothing + , breadthFirst = False + , breadthFirstStrict = False + , checkParseRhs = False + , checkParseTy = False + , checkParseBlock = False + , nocatas = Set.empty + , noOptimizations = False + , reference = False + , noIncludes = False + , outputStr = hPutStr stderr + , failWithCode = exitWith . ExitFailure + , mainFilename = Nothing + , beQuiet = False + + -- defaults for the KW-code path + , kennedyWarren = False + , parallelInvoke = False + , tupleAsDummyToken = True + , dummyTokenVisit = False + , strictDummyToken = False + , noPerRuleTypeSigs = False + , noPerStateTypeSigs = False + , noEagerBlackholing = False + , lateHigherOrderBinding = False + , monadicWrappers = False + + -- defaults for tracing + , genTraces = False + , genUseTraces = False + , genCostCentres = False + , noPerRuleCostCentres = False + , noPerVisitCostCentres = False + + -- defaults for inline pragma generation + , helpInlining = False + , noInlinePragmas = False + , aggressiveInlinePragmas = False + } + +loagOpt :: (Maybe String) -> Options -> Options +loagOpt mstr opts = + case mstr of + Nothing -> opts' + Just "0" -> opts' + Just _ -> opts' {minvisits = True} + + where opts'=opts{loag = True, visit = True} + +aoagOpt :: Options -> Options +aoagOpt opts = + opts{loag = True, visit = True, aoag = True} + +--Options -> String -> [String] +moduleOpt :: Maybe String -> Options -> Options +moduleOpt nm opts = opts{moduleName = maybe Default Name nm} +moduleOptGet :: Options -> String -> [String] +moduleOptGet opts nm = case moduleName opts of + NoName -> [] + Name s -> [nm++"="++s] + Default -> [nm] + +dataOpt, dataRecOpt, strictDataOpt, strictWrapOpt, cataOpt, semfunsOpt, signaturesOpt, prettyOpt,renameOpt, wrappersOpt, modcopyOpt, newtypesOpt, nestOpt, smacroOpt, verboseOpt, helpOpt, versionOpt, selfOpt, cycleOpt, visitOpt, seqOpt, unboxOpt, bangpatsOpt, casesOpt, strictCasesOpt, stricterCasesOpt, strictSemOpt, localCpsOpt, splitSemsOpt, werrorsOpt, wignoreOpt, dumpgrammarOpt, dumpcgrammarOpt, genTracesOpt, genUseTracesOpt, genCostCentresOpt, sepSemModsOpt, genFileDepsOpt, genLinePragmasOpt, genVisageOpt, genMirageOpt, genAspectAGOpt, dummyTokenVisitOpt, tupleAsDummyTokenOpt, stateAsDummyTokenOpt, strictDummyTokenOpt, noPerRuleTypeSigsOpt, noPerStateTypeSigsOpt, noEagerBlackholingOpt, noPerRuleCostCentresOpt, noPerVisitCostCentresOpt, helpInliningOpt, noInlinePragmasOpt, aggressiveInlinePragmasOpt, lateHigherOrderBindingOpt, monadicWrappersOpt, referenceOpt, genAttrListOpt, lcKeywordsOpt, doubleColonsOpt, haskellSyntaxOpt, monadicOpt, parallelOpt, ocamlOpt, cleanOpt, visitorsOutputOpt, breadthfirstOpt, breadthfirstStrictOpt, parseHsRhsOpt, parseHsTpOpt, parseHsBlockOpt, parseHsOpt, kennedyWarrenOpt, noOptimizeOpt, allOpt, optimizeOpt, noIncludesOpt, beQuietOpt, condDisableOptimizations :: Options -> Options + +dataOpt opts = opts{dataTypes = True} +dataRecOpt opts = opts{dataRecords = True} +strictDataOpt opts = opts{strictData = True} +strictWrapOpt opts = opts{strictWrap = True} +cataOpt opts = opts{folds = True} +semfunsOpt opts = opts{semfuns = True} +signaturesOpt opts = opts{typeSigs = True} +prettyOpt opts = opts{attrInfo = True} +renameOpt opts = opts{rename = True} +wrappersOpt opts = opts{wrappers = True} +modcopyOpt opts = opts{modcopy = True} +newtypesOpt opts = opts{newtypes = True} +nestOpt opts = opts{nest = True} +smacroOpt opts = opts{smacro = True} +verboseOpt opts = opts{verbose = True} +helpOpt opts = opts{showHelp = True} +versionOpt opts = opts{showVersion = True} +prefixOpt :: String -> Options -> Options +prefixOpt pre opts = opts{prefix = pre } +selfOpt opts = opts{withSelf = True} +cycleOpt opts = opts{withCycle = True} +visitOpt opts = opts{visit = True, withCycle = True} +seqOpt opts = opts{withSeq = True} +unboxOpt opts = opts{unbox = True} +bangpatsOpt opts = opts{bangpats = True} +casesOpt opts = opts{cases = True} +strictCasesOpt opts = opts{strictCases = True} +stricterCasesOpt opts = opts{strictCases = True, stricterCases = True} +strictSemOpt opts = opts{strictSems = True} +localCpsOpt opts = opts{localCps = True} +splitSemsOpt opts = opts{splitSems = True} +werrorsOpt opts = opts{werrors = True} +wignoreOpt opts = opts{wignore = True} +wmaxErrsOpt :: String -> Options -> Options +wmaxErrsOpt n opts = opts{wmaxerrs = read n} +wmaxErrsOptGet :: Options -> String -> [String] +wmaxErrsOptGet opts nm = if wmaxerrs opts /= wmaxerrs noOptions + then [nm,show (wmaxerrs opts)] + else [] +dumpgrammarOpt opts = opts{dumpgrammar = True} +dumpcgrammarOpt opts = opts{dumpcgrammar = True} +genTracesOpt opts = opts{genTraces = True} +genUseTracesOpt opts = opts{genUseTraces = True} +genCostCentresOpt opts = opts{genCostCentres = True} +sepSemModsOpt opts = opts{sepSemMods = allowSepSemMods opts} +genFileDepsOpt opts = opts{genFileDeps = True} +genLinePragmasOpt opts = opts{genLinePragmas = True} +genVisageOpt opts = opts{genvisage = True } +genMirageOpt opts = opts{genmirage = True } +genAspectAGOpt opts = opts{genAspectAG = True} + +dummyTokenVisitOpt opts = opts { dummyTokenVisit = True } +tupleAsDummyTokenOpt opts = opts { tupleAsDummyToken = True } +stateAsDummyTokenOpt opts = opts { tupleAsDummyToken = False } +strictDummyTokenOpt opts = opts { strictDummyToken = True } +noPerRuleTypeSigsOpt opts = opts { noPerRuleTypeSigs = True } +noPerStateTypeSigsOpt opts = opts { noPerStateTypeSigs = True } +noEagerBlackholingOpt opts = opts { noEagerBlackholing = True } +noPerRuleCostCentresOpt opts = opts { noPerRuleCostCentres = True } +noPerVisitCostCentresOpt opts = opts { noPerVisitCostCentres = True } +helpInliningOpt opts = opts { helpInlining = True } +noInlinePragmasOpt opts = opts { noInlinePragmas = True } +aggressiveInlinePragmasOpt opts = opts { aggressiveInlinePragmas = True } +lateHigherOrderBindingOpt opts = opts { lateHigherOrderBinding = True } +monadicWrappersOpt opts = opts { monadicWrappers = True } +referenceOpt opts = opts { reference = True } + +noGroupOpt :: String -> Options -> Options +noGroupOpt att opts = opts{noGroup = wordsBy (== ':') att ++ noGroup opts} +noGroupOptGet :: Options -> String -> [String] +noGroupOptGet opts nm = if null (noGroup opts) + then [] + else [nm, intercalate ":" (noGroup opts)] +extendsOpt :: String -> Options -> Options +extendsOpt m opts = opts{extends = Just m } + +genAttrListOpt opts = opts { genAttributeList = True } +forceIrrefutableOpt :: Maybe String -> Options -> Options +forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm } +uniqueDispenserOpt :: String -> Options -> Options +uniqueDispenserOpt nm opts = opts { uniqueDispenser = nm } +lcKeywordsOpt opts = opts { lcKeywords = True } +doubleColonsOpt opts = opts { doubleColons = True } +haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt +monadicOpt opts = opts { monadic = True } +parallelOpt opts = opts { parallelInvoke = True } +ocamlOpt opts = opts { ocaml = True, kennedyWarren = True, withCycle = True, visit = True } +cleanOpt opts = opts { clean = True } --TODO: More? +visitorsOutputOpt opts = opts { visitorsOutput = True } +statisticsOpt :: String -> Options -> Options +statisticsOpt nm opts = opts { statsFile = Just nm } +breadthfirstOpt opts = opts { breadthFirst = True } +breadthfirstStrictOpt opts = opts { breadthFirstStrict = True } +parseHsRhsOpt opts = opts { checkParseRhs = True } +parseHsTpOpt opts = opts { checkParseTy = True } +parseHsBlockOpt opts = opts { checkParseBlock = True } +parseHsOpt = parseHsRhsOpt . parseHsTpOpt . parseHsBlockOpt +kennedyWarrenOpt opts = opts { kennedyWarren = True } +noOptimizeOpt opts = opts { noOptimizations = True } +nocatasOpt :: String -> Options -> Options +nocatasOpt str opts = opts { nocatas = set `Set.union` nocatas opts } where + set = Set.fromList ids + ids = map identifier lst + lst = wordsBy (== ',') str +nocatasOptGet :: Options -> String -> [String] +nocatasOptGet opts nm = if Set.null (nocatas opts) + then [] + else [nm,intercalate "," . map getName . Set.toList . nocatas $ opts] +outputOpt :: String -> Options -> Options +outputOpt file opts = opts{outputFiles = file : outputFiles opts} +outputOptGet :: Options -> String -> [String] +outputOptGet opts nm = concat [ [nm, file] | file <- outputFiles opts] +searchPathOpt :: String -> Options -> Options +searchPathOpt path opts = opts{searchPath = wordsBy (\x -> x == ';' || x == ':') path ++ searchPath opts} +searchPathOptGet :: Options -> String -> [String] +searchPathOptGet opts nm = if null (searchPath opts) + then [] + else [nm, intercalate ":" (searchPath opts)] +allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt . dataRecOpt +optimizeOpt = visitOpt . casesOpt +noIncludesOpt opts = opts { noIncludes = True } +beQuietOpt opts = opts { beQuiet = True } + +condDisableOptimizations opts + | noOptimizations opts = + opts { strictData = False + , strictWrap = False + , withSeq = False + , unbox = False + , bangpats = False + , cases = False + , strictCases = False + , stricterCases = False + , strictSems = False + , localCps = False + , splitSems = False + , breadthFirstStrict = False + } + | otherwise = opts + +-- | Inverse of intercalate +wordsBy :: (Char -> Bool) -> String -> [String] +wordsBy p = f + where + f s = let (x,xs) = break p s + in if null x then [] else x : f (drop 1 xs) + +-- | Use all parsed options to generate real options +constructOptions :: [Options -> Options] -> Options +constructOptions = foldl (flip ($)) noOptions + +-- | Create Options type from string arguments +getOptions :: [String] -> (Options,[String],[String]) +getOptions args = let (flags,files,errors) = getOpt Permute options args + appliedOpts = constructOptions flags + finOpts = condDisableOptimizations appliedOpts + in (finOpts,files,errors) + +-- | Convert options back to commandline string +optionsToString :: Options -> [String] +optionsToString opt = concatMap (serializeOption opt) allOptions + +-- | Combine 2 sets of options +combineOptions :: Options -> Options -> Options +combineOptions o1 o2 = let str1 = optionsToString o1 + str2 = optionsToString o2 + (opt,_,_) = getOptions (str1 ++ str2) + in opt diff --git a/src/ATermAbstractSyntax.hs b/src/ATermAbstractSyntax.hs --- a/src/ATermAbstractSyntax.hs +++ b/src/ATermAbstractSyntax.hs @@ -1,23 +1,23 @@ -{----------------------------------------------------------------------------- - - Haskell ATerm Library - - Joost Visser - CWI, Amsterdam - - This module is part of the ATerm library for Haskell. It defines the - abstract syntax of ATerms as a Haskell datatype. - -------------------------------------------------------------------------------} - -module ATermAbstractSyntax where - --- Abstract syntax ----------------------------------------------------------- - -data ATerm = AAppl String [ATerm] - | AList [ATerm] - | AInt Integer - | AString String - deriving (Read,Show,Eq,Ord) - ------------------------------------------------------------------------------- +{----------------------------------------------------------------------------- + + Haskell ATerm Library + + Joost Visser + CWI, Amsterdam + + This module is part of the ATerm library for Haskell. It defines the + abstract syntax of ATerms as a Haskell datatype. + +------------------------------------------------------------------------------} + +module ATermAbstractSyntax where + +-- Abstract syntax ----------------------------------------------------------- + +data ATerm = AAppl String [ATerm] + | AList [ATerm] + | AInt Integer + | AString String + deriving (Read,Show,Eq,Ord) + +------------------------------------------------------------------------------ diff --git a/src/Ag.hs b/src/Ag.hs --- a/src/Ag.hs +++ b/src/Ag.hs @@ -1,558 +1,568 @@ --- Todo: we should make a nicer pipeline. Perhaps use Atze's "compile run" combinators. -module Ag (uuagcLib, uuagcExe,compile) where - -import System.Environment (getArgs, getProgName) -import System.Console.GetOpt (usageInfo) -import Data.List (partition) -import Control.Monad (zipWithM_,when) -import Data.Maybe -import System.FilePath -import System.IO - -import qualified Data.Set as Set -import qualified Data.Map as Map -import qualified Data.Sequence as Seq ((><),null) -import Data.Foldable(toList) -import Pretty -import PPUtil - -import UU.Parsing (Message(..), Action(..)) -import UU.Scanner.Position (Pos, line, file) -import UU.Scanner.Token (Token) - -import qualified Transform as Pass1 (sem_AG , wrap_AG , Syn_AG (..), Inh_AG (..)) -import qualified Desugar as Pass1a (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) -import qualified DefaultRules as Pass2 (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) -import qualified ResolveLocals as Pass2a (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) -import qualified Order as Pass3 (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) -import qualified LOAG.Order as Pass3b (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) -import qualified KWOrder as Pass3a (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) -import qualified GenerateCode as Pass4 (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..)) -import qualified PrintVisitCode as Pass4a (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..)) -import qualified ExecutionPlan2Hs as Pass4b (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..), warrenFlagsPP) -import qualified ExecutionPlan2Caml as Pass4c (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..)) -import qualified ExecutionPlan2Clean as Pass4d (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..), mkIclModuleHeader, mkDclModuleHeader, cleanIclModuleHeader, cleanDclModuleHeader) -import qualified PrintCode as Pass5 (sem_Program, wrap_Program, Syn_Program (..), Inh_Program (..)) -import qualified PrintOcamlCode as Pass5a (sem_Program, wrap_Program, Syn_Program (..), Inh_Program (..)) -import qualified PrintCleanCode as Pass5b (sem_Program, wrap_Program, Syn_Program (..), Inh_Program (..)) -import qualified PrintErrorMessages as PrErr (sem_Errors , wrap_Errors , Syn_Errors (..), Inh_Errors (..), isError) -import qualified TfmToVisage as PassV (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) - -import qualified AbstractSyntaxDump as GrammarDump (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) -import qualified CodeSyntaxDump as CGrammarDump (sem_CGrammar, wrap_CGrammar, Syn_CGrammar (..), Inh_CGrammar (..)) -import qualified Visage as VisageDump (sem_VisageGrammar, wrap_VisageGrammar, Syn_VisageGrammar(..), Inh_VisageGrammar(..)) -import qualified AG2AspectAG as AspectAGDump (pragmaAspectAG, sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) --marcos - -import Options -import Version (banner) -import Parser (parseAG, depsAG, parseAGI) -import ErrorMessages (Error(ParserError)) -import CommonTypes -import ATermWrite - --- Library version -import System.Exit (ExitCode(..), exitWith) - -uuagcLib :: [String] -> FilePath -> IO (ExitCode, [FilePath]) -uuagcLib args fileP - = do let (flags,_,errs) = getOptions args - if showVersion flags || showHelp flags - then do putStrLn "Cannot display help or version in library mode." - return (ExitFailure 1, []) - else if (not.null) errs - then do putStrLn "One or more errors occured:" - mapM_ putStrLn errs - return (ExitFailure 2, []) - else if genFileDeps flags - then do deps <- getDeps flags [fileP] - return (ExitSuccess, deps) - else do compile flags fileP (head $ outputFiles flags++repeat "") - return (ExitSuccess, []) - --- Executable version -uuagcExe :: IO () -uuagcExe - = do args <- getArgs - progName <- getProgName - - let usageheader = "Usage info:\n " ++ progName ++ " options file ...\n\nList of options:" - (flags,files,errs) = getOptions args - - if showVersion flags - then putStrLn banner - else if showHelp flags - then putStrLn (usageInfo usageheader options) - else if null files || (not.null) errs - then do mapM_ putStrLn (usageInfo usageheader options : errs) - exitWith (ExitFailure 2) - else if genFileDeps flags - then reportDeps flags files - else zipWithM_ (compile flags) files (outputFiles flags++repeat "") - - -compile :: Options -> FilePath -> FilePath -> IO () -compile flags input output - = do (output0,parseErrors) <- parseAG flags (searchPath flags) input - irrefutableMap <- readIrrefutableMap flags - let printStr = outputStr flags - failWith = failWithCode flags - inputfile = maybe input id (mainFilename flags) - let output1 = Pass1.wrap_AG (Pass1.sem_AG output0 ) Pass1.Inh_AG {Pass1.options_Inh_AG = flags} - flags' = condDisableOptimizations (Pass1.pragmas_Syn_AG output1 flags) - grammar1 = Pass1.output_Syn_AG output1 - output1a = Pass1a.wrap_Grammar (Pass1a.sem_Grammar grammar1 ) Pass1a.Inh_Grammar {Pass1a.options_Inh_Grammar = flags', Pass1a.forcedIrrefutables_Inh_Grammar = irrefutableMap, Pass1a.mainName_Inh_Grammar = mainName } - grammar1a = Pass1a.output_Syn_Grammar output1a - output2 = Pass2.wrap_Grammar (Pass2.sem_Grammar grammar1a ) Pass2.Inh_Grammar {Pass2.options_Inh_Grammar = flags', Pass2.constructorTypeMap_Inh_Grammar = Pass1.constructorTypeMap_Syn_AG output1} - grammar2 = Pass2.output_Syn_Grammar output2 - outputV = PassV.wrap_Grammar (PassV.sem_Grammar grammar2 ) PassV.Inh_Grammar {} - grammarV = PassV.visage_Syn_Grammar outputV - output2a = Pass2a.wrap_Grammar (Pass2a.sem_Grammar grammar2 ) Pass2a.Inh_Grammar {Pass2a.options_Inh_Grammar = flags'} - grammar2a = Pass2a.output_Syn_Grammar output2a - output3 = Pass3.wrap_Grammar (Pass3.sem_Grammar grammar2a ) Pass3.Inh_Grammar {Pass3.options_Inh_Grammar = flags'} - grammar3 = Pass3.output_Syn_Grammar output3 - output3a = Pass3a.wrap_Grammar (Pass3a.sem_Grammar grammar2a ) Pass3a.Inh_Grammar {Pass3a.options_Inh_Grammar = flags'} - output3b = Pass3b.wrap_Grammar (Pass3b.sem_Grammar grammar2a ) Pass3b.Inh_Grammar {Pass3b.options_Inh_Grammar = flags'} - grammar3a | loag flags' = Pass3b.output_Syn_Grammar output3b - | otherwise = Pass3a.output_Syn_Grammar output3a - output4 = Pass4.wrap_CGrammar (Pass4.sem_CGrammar(Pass3.output_Syn_Grammar output3)) Pass4.Inh_CGrammar {Pass4.options_Inh_CGrammar = flags'} - output4a = Pass4a.wrap_CGrammar (Pass4a.sem_CGrammar(Pass3.output_Syn_Grammar output3)) Pass4a.Inh_CGrammar {Pass4a.options_Inh_CGrammar = flags'} - output4b = Pass4b.wrap_ExecutionPlan (Pass4b.sem_ExecutionPlan grammar3a) Pass4b.Inh_ExecutionPlan {Pass4b.options_Inh_ExecutionPlan = flags', Pass4b.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4b.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4b.pragmaBlocks_Inh_ExecutionPlan = pragmaBlocksTxt, Pass4b.importBlocks_Inh_ExecutionPlan = importBlocksTxt, Pass4b.textBlocks_Inh_ExecutionPlan = textBlocksDoc, Pass4b.moduleHeader_Inh_ExecutionPlan = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainFile_Inh_ExecutionPlan = mainFile, Pass4b.textBlockMap_Inh_ExecutionPlan = textBlockMap, Pass4b.mainBlocksDoc_Inh_ExecutionPlan = mainBlocksDoc,Pass4b.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a} - output4c = Pass4c.wrap_ExecutionPlan (Pass4c.sem_ExecutionPlan grammar3a) Pass4c.Inh_ExecutionPlan {Pass4c.options_Inh_ExecutionPlan = flags', Pass4c.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4c.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4c.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4c.mainFile_Inh_ExecutionPlan = mainFile, Pass4c.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a} - output4d = Pass4d.wrap_ExecutionPlan (Pass4d.sem_ExecutionPlan grammar3a) Pass4d.Inh_ExecutionPlan {Pass4d.options_Inh_ExecutionPlan = flags', Pass4d.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4d.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4d.importBlocks_Inh_ExecutionPlan = importBlocksTxt, Pass4d.textBlocks_Inh_ExecutionPlan = textBlocksDoc, Pass4d.iclModuleHeader_Inh_ExecutionPlan = Pass4d.mkIclModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4d.dclModuleHeader_Inh_ExecutionPlan = Pass4d.mkDclModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4d.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4d.mainFile_Inh_ExecutionPlan = mainFile, Pass4d.textBlockMap_Inh_ExecutionPlan = textBlockMap, Pass4d.mainBlocksDoc_Inh_ExecutionPlan = mainBlocksDoc,Pass4d.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a, Pass4d.constructorTypeMap_Inh_ExecutionPlan = Pass1.constructorTypeMap_Syn_AG output1} - output5 = Pass5.wrap_Program (Pass5.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5.Inh_Program {Pass5.options_Inh_Program = flags', Pass5.pragmaBlocks_Inh_Program = pragmaBlocksTxt, Pass5.importBlocks_Inh_Program = importBlocksTxt, Pass5.textBlocks_Inh_Program = textBlocksDoc, Pass5.textBlockMap_Inh_Program = textBlockMap, Pass5.mainBlocksDoc_Inh_Program = mainBlocksDoc, Pass5.optionsLine_Inh_Program = optionsLine, Pass5.mainFile_Inh_Program = mainFile, Pass5.moduleHeader_Inh_Program = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass5.mainName_Inh_Program = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1} - output5a = Pass5a.wrap_Program (Pass5a.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5a.Inh_Program { Pass5a.options_Inh_Program = flags', Pass5a.textBlockMap_Inh_Program = textBlockMap } - output5b = Pass5b.wrap_Program (Pass5b.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5b.Inh_Program {Pass5b.options_Inh_Program = flags', Pass5b.pragmaBlocks_Inh_Program = pragmaBlocksTxt, Pass5b.importBlocks_Inh_Program = importBlocksTxt, Pass5b.textBlocks_Inh_Program = textBlocksDoc, Pass5b.textBlockMap_Inh_Program = textBlockMap, Pass5b.mainBlocksDoc_Inh_Program = mainBlocksDoc, Pass5b.optionsLine_Inh_Program = optionsLine, Pass5b.mainFile_Inh_Program = mainFile, Pass5b.moduleHeader_Inh_Program = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass5b.mainName_Inh_Program = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1} - output6 = PrErr.wrap_Errors (PrErr.sem_Errors errorsToReport) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags', PrErr.dups_Inh_Errors = [] } - - dump1 = GrammarDump.wrap_Grammar (GrammarDump.sem_Grammar grammar1 ) GrammarDump.Inh_Grammar - dump2 = GrammarDump.wrap_Grammar (GrammarDump.sem_Grammar grammar2 ) GrammarDump.Inh_Grammar - dump3 = CGrammarDump.wrap_CGrammar (CGrammarDump.sem_CGrammar grammar3 ) CGrammarDump.Inh_CGrammar - - - outputVisage = VisageDump.wrap_VisageGrammar (VisageDump.sem_VisageGrammar grammarV) VisageDump.Inh_VisageGrammar - aterm = VisageDump.aterm_Syn_VisageGrammar outputVisage - - parseErrorList = map message2error (parseErrors) - mainErrors = toList ( Pass1.errors_Syn_AG output1 - Seq.>< Pass1a.errors_Syn_Grammar output1a - Seq.>< Pass2.errors_Syn_Grammar output2 - Seq.>< Pass2a.errors_Syn_Grammar output2a) - furtherErrors = if loag flags' - then toList (Pass3b.errors_Syn_Grammar output3b) - else if kennedyWarren flags' - then let errs3a = Pass3a.errors_Syn_Grammar output3a - in if Seq.null errs3a - then if ocaml flags' - then toList ( Pass4c.errors_Syn_ExecutionPlan output4c ) - else if clean flags' - then toList ( Pass4d.errors_Syn_ExecutionPlan output4d ) - else toList ( Pass4b.errors_Syn_ExecutionPlan output4b ) - else toList errs3a - else toList ( Pass3.errors_Syn_Grammar output3 - Seq.>< Pass4.errors_Syn_CGrammar output4) - - errorList = if null parseErrorList - then mainErrors - ++ if null (filter (PrErr.isError flags') mainErrors) - then furtherErrors - else [] - else [head parseErrorList] - - fatalErrorList = filter (PrErr.isError flags') errorList - - allErrors = if wignore flags' - then fatalErrorList - else errorsToFront flags' errorList - - errorsToReport = take (wmaxerrs flags') allErrors - - errorsToStopOn = if werrors flags' - then errorList - else fatalErrorList - - blocks1 = (Pass1.blocks_Syn_AG output1) {-SM `Map.unionWith (++)` (Pass3.blocks_Syn_Grammar output3)-} - (pragmaBlocks, blocks2) = Map.partitionWithKey (\(k, at) _->k==BlockPragma && at == Nothing) blocks1 - (importBlocks, textBlocks) = Map.partitionWithKey (\(k, at) _->k==BlockImport && at == Nothing) blocks2 - - importBlocksTxt = vlist_sep "" . map addLocationPragma . concat . Map.elems $ importBlocks - textBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockOther, Nothing) $ textBlocks - mainBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockMain, Nothing) $ textBlocks - dataBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockData, Nothing) $ textBlocks - recBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockRec, Nothing) $ textBlocks - pragmaBlocksTxt = unlines . concat . map fst . concat . Map.elems $ pragmaBlocks - textBlockMap = Map.map (vlist_sep "" . map addLocationPragma) . Map.filterWithKey (\(_, at) _ -> at /= Nothing) $ textBlocks - - outputfile = if null output then outputFile flags' inputfile else output - mainFile | null output = outputFile flags' inputfile - | otherwise = output - mainName = dropExtension $ takeFileName inputfile - - addLocationPragma :: ([String], Pos) -> PP_Doc - addLocationPragma (strs, p) - | genLinePragmas flags' = - ppLinePragma flags' (line p) (file p) >-< vlist (map pp strs) - >-< ppWithLineNr (\l -> ppLinePragma flags' (l+1) outputfile) - | otherwise = vlist (map pp strs) - - optionsGHC = option (unbox flags') "-fglasgow-exts" ++ option (bangpats flags') "-XBangPatterns" - option True s = [s] - option False _ = [] - optionsLine | null optionsGHC = "" - | otherwise = "{-# OPTIONS_GHC " ++ unwords optionsGHC ++ " #-}" - - nrOfErrorsToReport = length $ filter (PrErr.isError flags') errorsToReport - nrOfWarningsToReport = length $ filter (not.(PrErr.isError flags')) errorsToReport - totalNrOfErrors = length $ filter (PrErr.isError flags') allErrors - totalNrOfWarnings = length $ filter (not.(PrErr.isError flags')) allErrors - additionalErrors = totalNrOfErrors - nrOfErrorsToReport - additionalWarnings = totalNrOfWarnings - nrOfWarningsToReport - pluralS n = if n == 1 then "" else "s" - - (outAgi, ext) <- --marcos - if genAspectAG flags' - then parseAGI flags (searchPath flags) (agiFile input) - else return (undefined, undefined) - - let ext' = fmap remAgi ext - outAgi1 = Pass1.wrap_AG (Pass1.sem_AG outAgi ) Pass1.Inh_AG {Pass1.options_Inh_AG = flags'} - agi = Pass1.agi_Syn_AG outAgi1 - aspectAG = AspectAGDump.wrap_Grammar (AspectAGDump.sem_Grammar grammar2 ) AspectAGDump.Inh_Grammar { AspectAGDump.options_Inh_Grammar = flags' - , AspectAGDump.agi_Inh_Grammar = agi - , AspectAGDump.ext_Inh_Grammar = ext' } --marcos - - printStr . formatErrors $ PrErr.pp_Syn_Errors output6 - - if additionalErrors > 0 - then printStr $ "\nPlus " ++ show additionalErrors ++ " more error" ++ pluralS additionalErrors ++ - if additionalWarnings > 0 - then " and " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n" - else ".\n" - else if additionalWarnings > 0 - then printStr $ "\nPlus " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n" - else return () - - -- show fake dependencies when found with --aoag - when (aoag flags' && verbose flags' && - isJust (Pass3b.ads_Syn_Grammar output3b)) $ - putStrLn (show $ fromJust $ Pass3b.ads_Syn_Grammar output3b) - - if not (null errorsToStopOn) -- note: this may already run quite a part of the compilation... - then failWith 1 - else - do - if genvisage flags' - then writeFile (outputfile++".visage") (writeATerm aterm) - else return () - - if genAttributeList flags' - then writeAttributeList (outputfile++".attrs") (Pass1a.allAttributes_Syn_Grammar output1a) - else return () - - if sepSemMods flags' - then do -- alternative module gen - if loag flags || kennedyWarren flags' - then if ocaml flags' - then error "sepsemmods is not implemented for the ocaml output generation" - else Pass4b.genIO_Syn_ExecutionPlan output4b - else Pass5.genIO_Syn_Program output5 - if not (null errorsToStopOn) then failWith 1 else return () - else do -- conventional module gen - let doc - | visitorsOutput flags' - = vlist [ pp_braces importBlocksTxt - , pp_braces textBlocksDoc - , vlist $ Pass4a.output_Syn_CGrammar output4a - ] - -- marcos AspectAG gen - | genAspectAG flags' - = vlist [ AspectAGDump.pragmaAspectAG - , pp optionsLine - , pp pragmaBlocksTxt - , pp $ take 70 ("-- UUAGC2AspectAG " ++ drop 50 banner ++ " (" ++ input) ++ ")" - , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 - then moduleHeader flags' mainName ext' - else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False - , pp importBlocksTxt - , AspectAGDump.imp_Syn_Grammar aspectAG - , pp "\n\n{-- AspectAG Code --}\n\n" - , AspectAGDump.pp_Syn_Grammar aspectAG - , dataBlocksDoc - , mainBlocksDoc - , textBlocksDoc - , if dumpgrammar flags' - then vlist [ pp "{- Dump of AGI" - , pp (show agi) - , pp "-}" - , pp "{- Dump of grammar with default rules" - , GrammarDump.pp_Syn_Grammar dump2 - , pp "-}" - ] - else empty] - | loag flags' || kennedyWarren flags' - = if ocaml flags' - then vlist - [ text "(* generated by UUAG from" >#< mainFile >#< "*)" - , pp pragmaBlocksTxt - , text "(* module imports *)" - , pp importBlocksTxt - , Pass4c.modules_Syn_ExecutionPlan output4c - , text "" - , text "(* generated data types *)" - , text "module Data__ = struct" - , indent 2 $ vlist - [ text "type __generated_by_uuagc__ = Generated_by_uuagc__" - , Pass4c.datas_Syn_ExecutionPlan output4c - ] - , text "end" - , text "open Data__" - , text "" - , text "(* embedded data types *)" - , dataBlocksDoc - , text "" - , text "(* embedded utilty functions *)" - , textBlocksDoc - , text "(* generated evaluationcode *)" - , text "module Code__ = struct" - , indent 2 $ vlist - [ text "let rec __generated_by_uuagc__ = Generated_by_uuagc__" - , Pass4c.code_Syn_ExecutionPlan output4c - , recBlocksDoc - ] - , text "end" - , text "open Code__" - , text "" - , text "(* main code *)" - , mainBlocksDoc - ] - else if clean flags' - then vlist - [ pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 - then Pass4d.cleanIclModuleHeader flags' mainName - else Pass4d.mkIclModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False - , pp importBlocksTxt - , dataBlocksDoc - , vlist [ pp $ "from Control.Monad.Identity import :: Identity" - , pp $ "import qualified Control.Monad.Identity as Control.Monad.Identity" - , pp $ "import Control.Monad.Identity" - , pp $ "from Control.Applicative import lift" - , pp $ "from Control.Monad import class Monad (..)" - ] - , mainBlocksDoc - , textBlocksDoc - , recBlocksDoc - --, pp $ "{-" - --, Pass3a.depgraphs_Syn_Grammar output3a - --, Pass3a.visitgraph_Syn_Grammar output3a - --, pp $ "-}" - , Pass4d.output_Syn_ExecutionPlan output4d - , if dumpgrammar flags' - then vlist [ pp "/* Dump of grammar with default rules" - , GrammarDump.pp_Syn_Grammar dump2 - , pp "*/" - ] - else empty] - - else vlist - [ Pass4b.warrenFlagsPP flags' - , pp pragmaBlocksTxt - , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 - then moduleHeader flags' mainName Nothing - else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False - , pp importBlocksTxt - , ( if tupleAsDummyToken flags' - then empty - else pp "import GHC.Prim" -- need it to pass State# - ) - , if parallelInvoke flags' - then vlist [ pp $ "import qualified System.IO.Unsafe(unsafePerformIO)" - , pp $ "import System.IO(IO)" - , pp $ "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"] - else vlist [ pp $ "import Control.Monad.Identity (Identity)" - , pp $ "import qualified Control.Monad.Identity" ] - , dataBlocksDoc - , mainBlocksDoc - , textBlocksDoc - , recBlocksDoc - --, pp $ "{-" - --, Pass3a.depgraphs_Syn_Grammar output3a - --, Pass3a.visitgraph_Syn_Grammar output3a - --, pp $ "-}" - , Pass4b.output_Syn_ExecutionPlan output4b - , if dumpgrammar flags' - then vlist [ pp "{- Dump of grammar with default rules" - , GrammarDump.pp_Syn_Grammar dump2 - , pp "-}" - ] - else empty] - | otherwise - = vlist [ vlist ( if (ocaml flags' || clean flags') - then [] - else [ pp optionsLine - , pp pragmaBlocksTxt - , pp $ take 70 ("-- UUAGC " ++ drop 50 banner ++ " (" ++ input) ++ ")" - , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 - then moduleHeader flags' mainName Nothing - else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False - ] - ) - , pp importBlocksTxt - , dataBlocksDoc - , mainBlocksDoc - , textBlocksDoc - , vlist $ if (ocaml flags') - then Pass5a.output_Syn_Program output5a - else if (clean flags') - then Pass5b.output_Syn_Program output5b - else Pass5.output_Syn_Program output5 - , if dumpgrammar flags' - then vlist [ pp "{- Dump of grammar without default rules" - , GrammarDump.pp_Syn_Grammar dump1 - , pp "-}" - , pp "{- Dump of grammar with default rules" - , GrammarDump.pp_Syn_Grammar dump2 - , pp "-}" - ] - else empty - , if dumpcgrammar flags' - then vlist [ pp "{- Dump of cgrammar" - , CGrammarDump.pp_Syn_CGrammar dump3 - , pp "-}" - ] - else empty - ] - - let docTxt = disp doc 50000 "" - writeFile outputfile docTxt - - -- HACK: write Clean DCL file - if clean flags' - then do let dclDoc = - vlist - [ pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 - then Pass4d.cleanDclModuleHeader flags' mainName Nothing -- TODO: What should be there instead of Nothing? - else Pass4d.mkDclModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False - , vlist [ pp $ "from Control.Monad.Identity import :: Identity" - , pp $ "import qualified Control.Monad.Identity as Control.Monad.Identity" - , pp $ "import Control.Monad.Identity" - , pp $ "from Control.Applicative import lift" - , pp $ "from Control.Monad import class Monad (..)" - ] - , Pass4d.output_dcl_Syn_ExecutionPlan output4d - ] - writeFile (replaceExtension outputfile ".dcl") (disp dclDoc 50000 "") - else return () - - -- HACK: write statistics - let nAuto = Pass3.nAutoRules_Syn_Grammar output3 - nExpl = Pass3.nExplicitRules_Syn_Grammar output3 - line' = inputfile ++ "," ++ show nAuto ++ "," ++ show nExpl ++ "\r\n" - case statsFile flags' of - Nothing -> return () - Just f -> appendFile f line' - if not (null errorsToStopOn) then failWith 1 else return () - - - -formatErrors :: PP_Doc -> String -formatErrors doc = disp doc 5000 "" - - -message2error :: Message Token Pos -> Error -message2error (Msg expect pos action) = ParserError pos (show expect) actionString - where actionString - = case action - of Insert s -> "inserting: " ++ show s - - Delete s -> "deleting: " ++ show s - - Other ms -> ms - -errorsToFront :: Options -> [Error] -> [Error] -errorsToFront flags mesgs = errs ++ warnings - where (errs,warnings) = partition (PrErr.isError flags) mesgs - -moduleHeader :: Options -> String -> Maybe String -> String -moduleHeader flags input export - = case moduleName flags - of Name nm -> genMod nm - Default -> genMod (defaultModuleName input) - NoName -> "" - where genMod x = "module " ++ x ++ genExp export x ++ " where" - genExp Nothing _ = "" - genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")" - ---marcos -agiFile :: String -> String -agiFile name = replaceExtension name "agi" - -remAgi :: String -> String -remAgi = dropExtension - -outputFile :: Options -> String -> String -outputFile opts name - | ocaml opts = replaceExtension name "ml" - | clean opts = replaceExtension name "icl" - | otherwise = replaceExtension name "hs" - -defaultModuleName :: String -> String -defaultModuleName = dropExtension - -mkMainName :: String -> Maybe (String, String,String) -> String -mkMainName defaultName Nothing - = defaultName -mkMainName _ (Just (name, _, _)) - = name - -mkModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String -mkModuleHeader Nothing defaultName suffix _ _ - = "module " ++ defaultName ++ suffix ++ " where" -mkModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports - = "module " ++ name ++ suffix ++ ex ++ " where\n" ++ imports ++ "\n" - where - ex = if null exports || (replaceExports && null addExports) - then "" - else if null addExports - then "(" ++ exports ++ ")" - else if replaceExports - then "(" ++ addExports ++ ")" - else "(" ++ exports ++ "," ++ addExports ++ ")" - -reportDeps :: Options -> [String] -> IO () -reportDeps flags files - = do deps <- getDeps flags files - mapM_ putStrLn deps - -getDeps :: Options -> [String] -> IO [String] -getDeps flags files - = do results <- mapM (depsAG flags (searchPath flags)) files - let (fs, mesgs) = foldr comb ([],[]) results - let errs = take (min 1 (wmaxerrs flags)) (map message2error mesgs) - let ppErrs = PrErr.wrap_Errors (PrErr.sem_Errors errs) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags, PrErr.dups_Inh_Errors = []} - if null errs - then return fs - else do hPutStrLn stderr . formatErrors $ PrErr.pp_Syn_Errors ppErrs - failWithCode flags 1 - return [] - where - comb :: ([a],[b]) -> ([a], [b]) -> ([a], [b]) - comb (fs, mesgs) (fsr, mesgsr) - = (fs ++ fsr, mesgs ++ mesgsr) - - -writeAttributeList :: String -> AttrMap -> IO () -writeAttributeList fileP mp - = writeFile fileP s - where - s = show $ map (\(x,y) -> (show x, y)) $ Map.toList $ Map.map (map (\(x,y) -> (show x, y)) . Map.toList . Map.map (map (\(x,y) -> (show x, show y)) . Set.toList)) $ mp - -readIrrefutableMap :: Options -> IO AttrMap -readIrrefutableMap flags - = case forceIrrefutables flags of - Just fileP -> do s <- readFile fileP - seq (length s) (return ()) - let lists :: [(String,[(String,[(String, String)])])] - lists = read s - return $ Map.fromList [ (identifier n, Map.fromList [(identifier c, Set.fromList [ (identifier fld, identifier attr) | (fld,attr) <- ss ]) | (c,ss) <- cs ]) | (n,cs) <- lists ] - Nothing -> return Map.empty - - +-- Todo: we should make a nicer pipeline. Perhaps use Atze's "compile run" combinators. +module Ag (uuagcLib, uuagcExe,compile) where + +import System.Environment (getArgs, getProgName) +import System.Console.GetOpt (usageInfo) +import Data.List (partition) +import Control.Monad (zipWithM_,when) +import Data.Maybe +import System.FilePath +import System.IO + +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Sequence as Seq ((><),null) +import Data.Foldable(toList) +import Pretty +import PPUtil + +import UU.Parsing (Message(..), Action(..)) +import UU.Scanner.Position (Pos, line, file) +import UU.Scanner.Token (Token) + +import qualified Transform as Pass1 (sem_AG , wrap_AG , Syn_AG (..), Inh_AG (..)) +import qualified Desugar as Pass1a (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) +import qualified DefaultRules as Pass2 (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) +import qualified ResolveLocals as Pass2a (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) +import qualified Order as Pass3 (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) +import qualified LOAG.Order as Pass3b (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) +import qualified KWOrder as Pass3a (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) +import qualified GenerateCode as Pass4 (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..)) +import qualified PrintVisitCode as Pass4a (sem_CGrammar, wrap_CGrammar, Syn_CGrammar(..), Inh_CGrammar(..)) +import qualified ExecutionPlan2Hs as Pass4b (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..), warrenFlagsPP) +import qualified ExecutionPlan2Caml as Pass4c (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..)) +import qualified ExecutionPlan2Clean as Pass4d (sem_ExecutionPlan, wrap_ExecutionPlan, Syn_ExecutionPlan(..), Inh_ExecutionPlan(..), mkIclModuleHeader, mkDclModuleHeader, cleanIclModuleHeader, cleanDclModuleHeader) +import qualified PrintCode as Pass5 (sem_Program, wrap_Program, Syn_Program (..), Inh_Program (..)) +import qualified PrintOcamlCode as Pass5a (sem_Program, wrap_Program, Syn_Program (..), Inh_Program (..)) +import qualified PrintCleanCode as Pass5b (sem_Program, wrap_Program, Syn_Program (..), Inh_Program (..)) +import qualified PrintErrorMessages as PrErr (sem_Errors , wrap_Errors , Syn_Errors (..), Inh_Errors (..), isError) +import qualified TfmToVisage as PassV (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) +import qualified TfmToMirage as PassM (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) + +import qualified AbstractSyntaxDump as GrammarDump (sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) +import qualified CodeSyntaxDump as CGrammarDump (sem_CGrammar, wrap_CGrammar, Syn_CGrammar (..), Inh_CGrammar (..)) +import qualified Visage as VisageDump (sem_VisageGrammar, wrap_VisageGrammar, Syn_VisageGrammar(..), Inh_VisageGrammar(..)) +import qualified AG2AspectAG as AspectAGDump (pragmaAspectAG, sem_Grammar, wrap_Grammar, Syn_Grammar (..), Inh_Grammar (..)) --marcos + +import Options +import Version (banner) +import Parser (parseAG, depsAG, parseAGI) +import ErrorMessages (Error(ParserError)) +import CommonTypes +import ATermWrite +import Data.Aeson (encode) +import qualified Data.ByteString.Lazy as ByteString + +-- Library version +import System.Exit (ExitCode(..), exitWith) + +uuagcLib :: [String] -> FilePath -> IO (ExitCode, [FilePath]) +uuagcLib args fileP + = do let (flags,_,errs) = getOptions args + if showVersion flags || showHelp flags + then do putStrLn "Cannot display help or version in library mode." + return (ExitFailure 1, []) + else if (not.null) errs + then do putStrLn "One or more errors occured:" + mapM_ putStrLn errs + return (ExitFailure 2, []) + else if genFileDeps flags + then do deps <- getDeps flags [fileP] + return (ExitSuccess, deps) + else do compile flags fileP (head $ outputFiles flags++repeat "") + return (ExitSuccess, []) + +-- Executable version +uuagcExe :: IO () +uuagcExe + = do args <- getArgs + progName <- getProgName + + let usageheader = "Usage info:\n " ++ progName ++ " options file ...\n\nList of options:" + (flags,files,errs) = getOptions args + + if showVersion flags + then putStrLn banner + else if showHelp flags + then putStrLn (usageInfo usageheader options) + else if null files || (not.null) errs + then do mapM_ putStrLn (usageInfo usageheader options : errs) + exitWith (ExitFailure 2) + else if genFileDeps flags + then reportDeps flags files + else zipWithM_ (compile flags) files (outputFiles flags++repeat "") + + +compile :: Options -> FilePath -> FilePath -> IO () +compile flags input output + = do (output0,parseErrors) <- parseAG flags (searchPath flags) input + irrefutableMap <- readIrrefutableMap flags + let printStr = outputStr flags + failWith = failWithCode flags + inputfile = maybe input id (mainFilename flags) + let output1 = Pass1.wrap_AG (Pass1.sem_AG output0 ) Pass1.Inh_AG {Pass1.options_Inh_AG = flags} + flags' = condDisableOptimizations (Pass1.pragmas_Syn_AG output1 flags) + grammar1 = Pass1.output_Syn_AG output1 + output1a = Pass1a.wrap_Grammar (Pass1a.sem_Grammar grammar1 ) Pass1a.Inh_Grammar {Pass1a.options_Inh_Grammar = flags', Pass1a.forcedIrrefutables_Inh_Grammar = irrefutableMap, Pass1a.mainName_Inh_Grammar = mainName } + grammar1a = Pass1a.output_Syn_Grammar output1a + output2 = Pass2.wrap_Grammar (Pass2.sem_Grammar grammar1a ) Pass2.Inh_Grammar {Pass2.options_Inh_Grammar = flags', Pass2.constructorTypeMap_Inh_Grammar = Pass1.constructorTypeMap_Syn_AG output1} + grammar2 = Pass2.output_Syn_Grammar output2 + outputV = PassV.wrap_Grammar (PassV.sem_Grammar grammar2 ) PassV.Inh_Grammar {} + grammarV = PassV.visage_Syn_Grammar outputV + outputM = PassM.wrap_Grammar (PassM.sem_Grammar grammar2 ) PassM.Inh_Grammar {PassM.options_Inh_Grammar = flags'} + output2a = Pass2a.wrap_Grammar (Pass2a.sem_Grammar grammar2 ) Pass2a.Inh_Grammar {Pass2a.options_Inh_Grammar = flags'} + grammar2a = Pass2a.output_Syn_Grammar output2a + output3 = Pass3.wrap_Grammar (Pass3.sem_Grammar grammar2a ) Pass3.Inh_Grammar {Pass3.options_Inh_Grammar = flags'} + grammar3 = Pass3.output_Syn_Grammar output3 + output3a = Pass3a.wrap_Grammar (Pass3a.sem_Grammar grammar2a ) Pass3a.Inh_Grammar {Pass3a.options_Inh_Grammar = flags'} + output3b = Pass3b.wrap_Grammar (Pass3b.sem_Grammar grammar2a ) Pass3b.Inh_Grammar {Pass3b.options_Inh_Grammar = flags'} + grammar3a | loag flags' = Pass3b.output_Syn_Grammar output3b + | otherwise = Pass3a.output_Syn_Grammar output3a + output4 = Pass4.wrap_CGrammar (Pass4.sem_CGrammar(Pass3.output_Syn_Grammar output3)) Pass4.Inh_CGrammar {Pass4.options_Inh_CGrammar = flags'} + output4a = Pass4a.wrap_CGrammar (Pass4a.sem_CGrammar(Pass3.output_Syn_Grammar output3)) Pass4a.Inh_CGrammar {Pass4a.options_Inh_CGrammar = flags'} + output4b = Pass4b.wrap_ExecutionPlan (Pass4b.sem_ExecutionPlan grammar3a) Pass4b.Inh_ExecutionPlan {Pass4b.options_Inh_ExecutionPlan = flags', Pass4b.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4b.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4b.pragmaBlocks_Inh_ExecutionPlan = pragmaBlocksTxt, Pass4b.importBlocks_Inh_ExecutionPlan = importBlocksTxt, Pass4b.textBlocks_Inh_ExecutionPlan = textBlocksDoc, Pass4b.moduleHeader_Inh_ExecutionPlan = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4b.mainFile_Inh_ExecutionPlan = mainFile, Pass4b.textBlockMap_Inh_ExecutionPlan = textBlockMap, Pass4b.mainBlocksDoc_Inh_ExecutionPlan = mainBlocksDoc,Pass4b.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a} + output4c = Pass4c.wrap_ExecutionPlan (Pass4c.sem_ExecutionPlan grammar3a) Pass4c.Inh_ExecutionPlan {Pass4c.options_Inh_ExecutionPlan = flags', Pass4c.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4c.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4c.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4c.mainFile_Inh_ExecutionPlan = mainFile, Pass4c.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a} + output4d = Pass4d.wrap_ExecutionPlan (Pass4d.sem_ExecutionPlan grammar3a) Pass4d.Inh_ExecutionPlan {Pass4d.options_Inh_ExecutionPlan = flags', Pass4d.inhmap_Inh_ExecutionPlan = Pass3a.inhmap_Syn_Grammar output3a, Pass4d.synmap_Inh_ExecutionPlan = Pass3a.synmap_Syn_Grammar output3a, Pass4d.importBlocks_Inh_ExecutionPlan = importBlocksTxt, Pass4d.textBlocks_Inh_ExecutionPlan = textBlocksDoc, Pass4d.iclModuleHeader_Inh_ExecutionPlan = Pass4d.mkIclModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4d.dclModuleHeader_Inh_ExecutionPlan = Pass4d.mkDclModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass4d.mainName_Inh_ExecutionPlan = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1, Pass4d.mainFile_Inh_ExecutionPlan = mainFile, Pass4d.textBlockMap_Inh_ExecutionPlan = textBlockMap, Pass4d.mainBlocksDoc_Inh_ExecutionPlan = mainBlocksDoc,Pass4d.localAttrTypes_Inh_ExecutionPlan = Pass3a.localSigMap_Syn_Grammar output3a, Pass4d.constructorTypeMap_Inh_ExecutionPlan = Pass1.constructorTypeMap_Syn_AG output1} + output5 = Pass5.wrap_Program (Pass5.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5.Inh_Program {Pass5.options_Inh_Program = flags', Pass5.pragmaBlocks_Inh_Program = pragmaBlocksTxt, Pass5.importBlocks_Inh_Program = importBlocksTxt, Pass5.textBlocks_Inh_Program = textBlocksDoc, Pass5.textBlockMap_Inh_Program = textBlockMap, Pass5.mainBlocksDoc_Inh_Program = mainBlocksDoc, Pass5.optionsLine_Inh_Program = optionsLine, Pass5.mainFile_Inh_Program = mainFile, Pass5.moduleHeader_Inh_Program = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass5.mainName_Inh_Program = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1} + output5a = Pass5a.wrap_Program (Pass5a.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5a.Inh_Program { Pass5a.options_Inh_Program = flags', Pass5a.textBlockMap_Inh_Program = textBlockMap } + output5b = Pass5b.wrap_Program (Pass5b.sem_Program (Pass4.output_Syn_CGrammar output4)) Pass5b.Inh_Program {Pass5b.options_Inh_Program = flags', Pass5b.pragmaBlocks_Inh_Program = pragmaBlocksTxt, Pass5b.importBlocks_Inh_Program = importBlocksTxt, Pass5b.textBlocks_Inh_Program = textBlocksDoc, Pass5b.textBlockMap_Inh_Program = textBlockMap, Pass5b.mainBlocksDoc_Inh_Program = mainBlocksDoc, Pass5b.optionsLine_Inh_Program = optionsLine, Pass5b.mainFile_Inh_Program = mainFile, Pass5b.moduleHeader_Inh_Program = mkModuleHeader $ Pass1.moduleDecl_Syn_AG output1, Pass5b.mainName_Inh_Program = mkMainName mainName $ Pass1.moduleDecl_Syn_AG output1} + output6 = PrErr.wrap_Errors (PrErr.sem_Errors errorsToReport) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags', PrErr.dups_Inh_Errors = [] } + + dump1 = GrammarDump.wrap_Grammar (GrammarDump.sem_Grammar grammar1 ) GrammarDump.Inh_Grammar + dump2 = GrammarDump.wrap_Grammar (GrammarDump.sem_Grammar grammar2 ) GrammarDump.Inh_Grammar + dump3 = CGrammarDump.wrap_CGrammar (CGrammarDump.sem_CGrammar grammar3 ) CGrammarDump.Inh_CGrammar + + + outputVisage = VisageDump.wrap_VisageGrammar (VisageDump.sem_VisageGrammar grammarV) VisageDump.Inh_VisageGrammar + aterm = VisageDump.aterm_Syn_VisageGrammar outputVisage + + mirage = PassM.mirage_Syn_Grammar outputM + + parseErrorList = map message2error (parseErrors) + mainErrors = toList ( Pass1.errors_Syn_AG output1 + Seq.>< Pass1a.errors_Syn_Grammar output1a + Seq.>< Pass2.errors_Syn_Grammar output2 + Seq.>< Pass2a.errors_Syn_Grammar output2a) + furtherErrors = if loag flags' + then toList (Pass3b.errors_Syn_Grammar output3b) + else if kennedyWarren flags' + then let errs3a = Pass3a.errors_Syn_Grammar output3a + in if Seq.null errs3a + then if ocaml flags' + then toList ( Pass4c.errors_Syn_ExecutionPlan output4c ) + else if clean flags' + then toList ( Pass4d.errors_Syn_ExecutionPlan output4d ) + else toList ( Pass4b.errors_Syn_ExecutionPlan output4b ) + else toList errs3a + else toList ( Pass3.errors_Syn_Grammar output3 + Seq.>< Pass4.errors_Syn_CGrammar output4) + + errorList = if null parseErrorList + then mainErrors + ++ if null (filter (PrErr.isError flags') mainErrors) + then furtherErrors + else [] + else [head parseErrorList] + + fatalErrorList = filter (PrErr.isError flags') errorList + + allErrors = if wignore flags' + then fatalErrorList + else errorsToFront flags' errorList + + errorsToReport = take (wmaxerrs flags') allErrors + + errorsToStopOn = if werrors flags' + then errorList + else fatalErrorList + + blocks1 = (Pass1.blocks_Syn_AG output1) {-SM `Map.unionWith (++)` (Pass3.blocks_Syn_Grammar output3)-} + (pragmaBlocks, blocks2) = Map.partitionWithKey (\(k, at) _->k==BlockPragma && at == Nothing) blocks1 + (importBlocks, textBlocks) = Map.partitionWithKey (\(k, at) _->k==BlockImport && at == Nothing) blocks2 + + importBlocksTxt = vlist_sep "" . map addLocationPragma . concat . Map.elems $ importBlocks + textBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockOther, Nothing) $ textBlocks + mainBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockMain, Nothing) $ textBlocks + dataBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockData, Nothing) $ textBlocks + recBlocksDoc = vlist_sep "" . map addLocationPragma . Map.findWithDefault [] (BlockRec, Nothing) $ textBlocks + pragmaBlocksTxt = unlines . concat . map fst . concat . Map.elems $ pragmaBlocks + textBlockMap = Map.map (vlist_sep "" . map addLocationPragma) . Map.filterWithKey (\(_, at) _ -> at /= Nothing) $ textBlocks + + outputfile = if null output then outputFile flags' inputfile else output + mainFile | null output = outputFile flags' inputfile + | otherwise = output + mainName = dropExtension $ takeFileName inputfile + + addLocationPragma :: ([String], Pos) -> PP_Doc + addLocationPragma (strs, p) + | genLinePragmas flags' = + ppLinePragma flags' (line p) (file p) >-< vlist (map pp strs) + >-< ppWithLineNr (\l -> ppLinePragma flags' (l+1) outputfile) + | otherwise = vlist (map pp strs) + + optionsGHC = option (unbox flags') "-fglasgow-exts" ++ option (bangpats flags') "-XBangPatterns" + option True s = [s] + option False _ = [] + optionsLine | null optionsGHC = "" + | otherwise = "{-# OPTIONS_GHC " ++ unwords optionsGHC ++ " #-}" + + nrOfErrorsToReport = length $ filter (PrErr.isError flags') errorsToReport + nrOfWarningsToReport = length $ filter (not.(PrErr.isError flags')) errorsToReport + totalNrOfErrors = length $ filter (PrErr.isError flags') allErrors + totalNrOfWarnings = length $ filter (not.(PrErr.isError flags')) allErrors + additionalErrors = totalNrOfErrors - nrOfErrorsToReport + additionalWarnings = totalNrOfWarnings - nrOfWarningsToReport + pluralS n = if n == 1 then "" else "s" + + (outAgi, ext) <- --marcos + if genAspectAG flags' + then parseAGI flags (searchPath flags) (agiFile input) + else return (undefined, undefined) + + let ext' = fmap remAgi ext + outAgi1 = Pass1.wrap_AG (Pass1.sem_AG outAgi ) Pass1.Inh_AG {Pass1.options_Inh_AG = flags'} + agi = Pass1.agi_Syn_AG outAgi1 + aspectAG = AspectAGDump.wrap_Grammar (AspectAGDump.sem_Grammar grammar2 ) AspectAGDump.Inh_Grammar { AspectAGDump.options_Inh_Grammar = flags' + , AspectAGDump.agi_Inh_Grammar = agi + , AspectAGDump.ext_Inh_Grammar = ext' } --marcos + + printStr . formatErrors $ PrErr.pp_Syn_Errors output6 + + if additionalErrors > 0 + then printStr $ "\nPlus " ++ show additionalErrors ++ " more error" ++ pluralS additionalErrors ++ + if additionalWarnings > 0 + then " and " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n" + else ".\n" + else if additionalWarnings > 0 + then printStr $ "\nPlus " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n" + else return () + + -- show fake dependencies when found with --aoag + when (aoag flags' && verbose flags' && + isJust (Pass3b.ads_Syn_Grammar output3b)) $ + putStrLn (show $ fromJust $ Pass3b.ads_Syn_Grammar output3b) + + if not (null errorsToStopOn) -- note: this may already run quite a part of the compilation... + then failWith 1 + else + do + if genvisage flags' + then writeFile (outputfile++".visage") (writeATerm aterm) + else return () + + if genmirage flags' + then ByteString.writeFile (outputfile++".mirage") (encode mirage) + else return () + + if genAttributeList flags' + then writeAttributeList (outputfile++".attrs") (Pass1a.allAttributes_Syn_Grammar output1a) + else return () + + if sepSemMods flags' + then do -- alternative module gen + if loag flags || kennedyWarren flags' + then if ocaml flags' + then error "sepsemmods is not implemented for the ocaml output generation" + else Pass4b.genIO_Syn_ExecutionPlan output4b + else Pass5.genIO_Syn_Program output5 + if not (null errorsToStopOn) then failWith 1 else return () + else do -- conventional module gen + let doc + | visitorsOutput flags' + = vlist [ pp_braces importBlocksTxt + , pp_braces textBlocksDoc + , vlist $ Pass4a.output_Syn_CGrammar output4a + ] + -- marcos AspectAG gen + | genAspectAG flags' + = vlist [ AspectAGDump.pragmaAspectAG + , pp optionsLine + , pp pragmaBlocksTxt + , pp $ take 70 ("-- UUAGC2AspectAG " ++ drop 50 banner ++ " (" ++ input) ++ ")" + , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 + then moduleHeader flags' mainName ext' + else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False + , pp importBlocksTxt + , AspectAGDump.imp_Syn_Grammar aspectAG + , pp "\n\n{-- AspectAG Code --}\n\n" + , AspectAGDump.pp_Syn_Grammar aspectAG + , dataBlocksDoc + , mainBlocksDoc + , textBlocksDoc + , if dumpgrammar flags' + then vlist [ pp "{- Dump of AGI" + , pp (show agi) + , pp "-}" + , pp "{- Dump of grammar with default rules" + , GrammarDump.pp_Syn_Grammar dump2 + , pp "-}" + ] + else empty] + | loag flags' || kennedyWarren flags' + = if ocaml flags' + then vlist + [ text "(* generated by UUAG from" >#< mainFile >#< "*)" + , pp pragmaBlocksTxt + , text "(* module imports *)" + , pp importBlocksTxt + , Pass4c.modules_Syn_ExecutionPlan output4c + , text "" + , text "(* generated data types *)" + , text "module Data__ = struct" + , indent 2 $ vlist + [ text "type __generated_by_uuagc__ = Generated_by_uuagc__" + , Pass4c.datas_Syn_ExecutionPlan output4c + ] + , text "end" + , text "open Data__" + , text "" + , text "(* embedded data types *)" + , dataBlocksDoc + , text "" + , text "(* embedded utilty functions *)" + , textBlocksDoc + , text "(* generated evaluationcode *)" + , text "module Code__ = struct" + , indent 2 $ vlist + [ text "let rec __generated_by_uuagc__ = Generated_by_uuagc__" + , Pass4c.code_Syn_ExecutionPlan output4c + , recBlocksDoc + ] + , text "end" + , text "open Code__" + , text "" + , text "(* main code *)" + , mainBlocksDoc + ] + else if clean flags' + then vlist + [ pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 + then Pass4d.cleanIclModuleHeader flags' mainName + else Pass4d.mkIclModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False + , pp importBlocksTxt + , dataBlocksDoc + , vlist [ pp $ "from Control.Monad.Identity import :: Identity" + , pp $ "import qualified Control.Monad.Identity as Control.Monad.Identity" + , pp $ "import Control.Monad.Identity" + , pp $ "from Control.Applicative import lift" + , pp $ "from Control.Monad import class Monad (..)" + ] + , mainBlocksDoc + , textBlocksDoc + , recBlocksDoc + --, pp $ "{-" + --, Pass3a.depgraphs_Syn_Grammar output3a + --, Pass3a.visitgraph_Syn_Grammar output3a + --, pp $ "-}" + , Pass4d.output_Syn_ExecutionPlan output4d + , if dumpgrammar flags' + then vlist [ pp "/* Dump of grammar with default rules" + , GrammarDump.pp_Syn_Grammar dump2 + , pp "*/" + ] + else empty] + + else vlist + [ Pass4b.warrenFlagsPP flags' + , pp pragmaBlocksTxt + , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 + then moduleHeader flags' mainName Nothing + else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False + , pp importBlocksTxt + , ( if tupleAsDummyToken flags' + then empty + else pp "import GHC.Prim" -- need it to pass State# + ) + , if parallelInvoke flags' + then vlist [ pp $ "import qualified System.IO.Unsafe(unsafePerformIO)" + , pp $ "import System.IO(IO)" + , pp $ "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"] + else vlist [ pp $ "import Control.Monad.Identity (Identity)" + , pp $ "import qualified Control.Monad.Identity" ] + , dataBlocksDoc + , mainBlocksDoc + , textBlocksDoc + , recBlocksDoc + --, pp $ "{-" + --, Pass3a.depgraphs_Syn_Grammar output3a + --, Pass3a.visitgraph_Syn_Grammar output3a + --, pp $ "-}" + , Pass4b.output_Syn_ExecutionPlan output4b + , if dumpgrammar flags' + then vlist [ pp "{- Dump of grammar with default rules" + , GrammarDump.pp_Syn_Grammar dump2 + , pp "-}" + ] + else empty] + | otherwise + = vlist [ vlist ( if (ocaml flags' || clean flags') + then [] + else [ pp optionsLine + , pp pragmaBlocksTxt + , pp $ take 70 ("-- UUAGC " ++ drop 50 banner ++ " (" ++ input) ++ ")" + , pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 + then moduleHeader flags' mainName Nothing + else mkModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False + ] + ) + , pp importBlocksTxt + , dataBlocksDoc + , mainBlocksDoc + , textBlocksDoc + , vlist $ if (ocaml flags') + then Pass5a.output_Syn_Program output5a + else if (clean flags') + then Pass5b.output_Syn_Program output5b + else Pass5.output_Syn_Program output5 + , if dumpgrammar flags' + then vlist [ pp "{- Dump of grammar without default rules" + , GrammarDump.pp_Syn_Grammar dump1 + , pp "-}" + , pp "{- Dump of grammar with default rules" + , GrammarDump.pp_Syn_Grammar dump2 + , pp "-}" + ] + else empty + , if dumpcgrammar flags' + then vlist [ pp "{- Dump of cgrammar" + , CGrammarDump.pp_Syn_CGrammar dump3 + , pp "-}" + ] + else empty + ] + + let docTxt = disp doc 50000 "" + writeFile outputfile docTxt + + -- HACK: write Clean DCL file + if clean flags' + then do let dclDoc = + vlist + [ pp $ if isNothing $ Pass1.moduleDecl_Syn_AG output1 + then Pass4d.cleanDclModuleHeader flags' mainName Nothing -- TODO: What should be there instead of Nothing? + else Pass4d.mkDclModuleHeader (Pass1.moduleDecl_Syn_AG output1) mainName "" "" False + , vlist [ pp $ "from Control.Monad.Identity import :: Identity" + , pp $ "import qualified Control.Monad.Identity as Control.Monad.Identity" + , pp $ "import Control.Monad.Identity" + , pp $ "from Control.Applicative import lift" + , pp $ "from Control.Monad import class Monad (..)" + ] + , Pass4d.output_dcl_Syn_ExecutionPlan output4d + ] + writeFile (replaceExtension outputfile ".dcl") (disp dclDoc 50000 "") + else return () + + -- HACK: write statistics + let nAuto = Pass3.nAutoRules_Syn_Grammar output3 + nExpl = Pass3.nExplicitRules_Syn_Grammar output3 + line' = inputfile ++ "," ++ show nAuto ++ "," ++ show nExpl ++ "\r\n" + case statsFile flags' of + Nothing -> return () + Just f -> appendFile f line' + if not (null errorsToStopOn) then failWith 1 else return () + + + +formatErrors :: PP_Doc -> String +formatErrors doc = disp doc 5000 "" + + +message2error :: Message Token Pos -> Error +message2error (Msg expect pos action) = ParserError pos (show expect) actionString + where actionString + = case action + of Insert s -> "inserting: " ++ show s + + Delete s -> "deleting: " ++ show s + + Other ms -> ms + +errorsToFront :: Options -> [Error] -> [Error] +errorsToFront flags mesgs = errs ++ warnings + where (errs,warnings) = partition (PrErr.isError flags) mesgs + +moduleHeader :: Options -> String -> Maybe String -> String +moduleHeader flags input export + = case moduleName flags + of Name nm -> genMod nm + Default -> genMod (defaultModuleName input) + NoName -> "" + where genMod x = "module " ++ x ++ genExp export x ++ " where" + genExp Nothing _ = "" + genExp (Just e) x = "(module " ++ x ++ ", module " ++ e ++ ")" + +--marcos +agiFile :: String -> String +agiFile name = replaceExtension name "agi" + +remAgi :: String -> String +remAgi = dropExtension + +outputFile :: Options -> String -> String +outputFile opts name + | ocaml opts = replaceExtension name "ml" + | clean opts = replaceExtension name "icl" + | otherwise = replaceExtension name "hs" + +defaultModuleName :: String -> String +defaultModuleName = dropExtension + +mkMainName :: String -> Maybe (String, String,String) -> String +mkMainName defaultName Nothing + = defaultName +mkMainName _ (Just (name, _, _)) + = name + +mkModuleHeader :: Maybe (String,String,String) -> String -> String -> String -> Bool -> String +mkModuleHeader Nothing defaultName suffix _ _ + = "module " ++ defaultName ++ suffix ++ " where" +mkModuleHeader (Just (name, exports, imports)) _ suffix addExports replaceExports + = "module " ++ name ++ suffix ++ ex ++ " where\n" ++ imports ++ "\n" + where + ex = if null exports || (replaceExports && null addExports) + then "" + else if null addExports + then "(" ++ exports ++ ")" + else if replaceExports + then "(" ++ addExports ++ ")" + else "(" ++ exports ++ "," ++ addExports ++ ")" + +reportDeps :: Options -> [String] -> IO () +reportDeps flags files + = do deps <- getDeps flags files + mapM_ putStrLn deps + +getDeps :: Options -> [String] -> IO [String] +getDeps flags files + = do results <- mapM (depsAG flags (searchPath flags)) files + let (fs, mesgs) = foldr comb ([],[]) results + let errs = take (min 1 (wmaxerrs flags)) (map message2error mesgs) + let ppErrs = PrErr.wrap_Errors (PrErr.sem_Errors errs) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags, PrErr.dups_Inh_Errors = []} + if null errs + then return fs + else do hPutStrLn stderr . formatErrors $ PrErr.pp_Syn_Errors ppErrs + failWithCode flags 1 + return [] + where + comb :: ([a],[b]) -> ([a], [b]) -> ([a], [b]) + comb (fs, mesgs) (fsr, mesgsr) + = (fs ++ fsr, mesgs ++ mesgsr) + + +writeAttributeList :: String -> AttrMap -> IO () +writeAttributeList fileP mp + = writeFile fileP s + where + s = show $ map (\(x,y) -> (show x, y)) $ Map.toList $ Map.map (map (\(x,y) -> (show x, y)) . Map.toList . Map.map (map (\(x,y) -> (show x, show y)) . Set.toList)) $ mp + +readIrrefutableMap :: Options -> IO AttrMap +readIrrefutableMap flags + = case forceIrrefutables flags of + Just fileP -> do s <- readFile fileP + seq (length s) (return ()) + let lists :: [(String,[(String,[(String, String)])])] + lists = read s + return $ Map.fromList [ (identifier n, Map.fromList [(identifier c, Set.fromList [ (identifier fld, identifier attr) | (fld,attr) <- ss ]) | (c,ss) <- cs ]) | (n,cs) <- lists ] + Nothing -> return Map.empty + + diff --git a/src/CommonTypes.hs b/src/CommonTypes.hs --- a/src/CommonTypes.hs +++ b/src/CommonTypes.hs @@ -1,287 +1,287 @@ -module CommonTypes (module Options, module CommonTypes) where - -import Options -import UU.Scanner.Position(Pos) -import qualified Data.Map as Map -import Data.Map(Map) -import Data.Set(Set) -import qualified Data.Set as Set -import Data.Monoid(mappend,Monoid) -import Data.Char -import Pretty - -type Blocks = Map BlockInfo [([String], Pos)] -type BlockInfo = (BlockKind, Maybe NontermIdent) -data BlockKind - = BlockImport - | BlockPragma - | BlockMain - | BlockData - | BlockRec - | BlockOther - deriving (Eq, Ord, Show) - -instance PP Identifier where - pp = text . getName - -data Type = Haskell String - | NT Identifier [String] - Bool -- True: deforested nonterminal, False: nonterminal type - | Self -- reference to the enclosing nonterminal type - deriving (Eq) - -data ComplexType = List Type - | Tuple [(Identifier, Type)] - | Maybe Type - | Either Type Type - | Map Type Type - | IntMap Type - | OrdSet Type - | IntSet - -instance Show ComplexType where - show (List t ) = "[" ++ show t ++ "]" - show (Tuple ts) = "(" ++ showList [ show n ++ ": " ++ show t | (n,t) <- ts ] "" ++ ")" - show (Maybe t ) = "Maybe " ++ show t - show (Either t1 t2) = "Either " ++ show t1 ++ " " ++ show t2 - show (Map t1 t2) = "Map " ++ show t1 ++ " " ++ show t2 - show (IntMap t1) = "IntMap " ++ show t1 - show (OrdSet t1) = "Set" ++ show t1 - show IntSet = "IntSet" - -instance Show Type where - show = typeToHaskellString Nothing [] - -type Attributes = Map Identifier Type -type TypeSyns = [(NontermIdent,ComplexType)] -type ParamMap = Map NontermIdent [Identifier] -type AttrNames = [(Identifier,Type,(String,String,String))] -type UseMap = Map NontermIdent (Map Identifier (String,String,String)) -type PragmaMap = Map NontermIdent (Map ConstructorIdent (Set Identifier)) -type AttrMap = Map NontermIdent (Map ConstructorIdent (Set (Identifier,Identifier))) -type UniqueMap = Map NontermIdent (Map ConstructorIdent (Map Identifier Identifier)) -type Derivings = Map NontermIdent (Set Identifier) -type ClassContext = [(Identifier, [String])] -type ContextMap = Map NontermIdent ClassContext -type QuantMap = Map NontermIdent [String] -type Strings = [String] -type ConstructorIdent = Identifier -type AttrOrderMap = Map NontermIdent (Map ConstructorIdent (Set Dependency)) -type VisitIdentifier = Int -type StateIdentifier = Int -data Dependency = Dependency Occurrence Occurrence deriving (Eq,Ord,Show) -data Occurrence - = OccAttr Identifier Identifier - | OccRule Identifier - deriving (Eq,Ord,Show) -data ConstructorType - = DataConstructor - | RecordConstructor - deriving (Eq,Ord,Show) - -type AttrEnv = ( [Identifier] - , [(Identifier,Identifier)] - ) - -nullIdent, _LHS, _SELF, _LOC, _INST, _INST', _FIELD, _FIRST, _LAST :: Identifier -nullIdent = identifier "" -_LHS = identifier "lhs" -_SELF = identifier "SELF" -_LOC = identifier "loc" -_INST = identifier "inst" -_INST' = identifier "inst'" -_FIELD = identifier "field" -_FIRST = identifier "first__" -_LAST = identifier "last__" - -idLateBindingAttr :: Identifier -idLateBindingAttr = identifier "lateSemDict" - -lateBindingTypeNm :: String -> String -lateBindingTypeNm modNm = "Late_" ++ modNm ++ "_" - -lateBindingFieldNm :: String -> String -lateBindingFieldNm modNm = "late_" ++ modNm ++ "_" - -lateBindingType :: String -> Type -lateBindingType modNm = Haskell (lateBindingTypeNm modNm) - -lateSemNtLabel :: NontermIdent -> String -lateSemNtLabel nt = "mk_" ++ getName nt - -lateSemConLabel :: NontermIdent -> ConstructorIdent -> String -lateSemConLabel nt con = "mk_" ++ getName nt ++ "_" ++ getName con - -sdtype :: NontermIdent -> String -sdtype nt = "T_"++getName nt - -mkNtType :: Identifier -> [String] -> Type -mkNtType nt args - | take 2 (getName nt) == "T_" = let nt' = Ident (drop 2 (getName nt)) (getPos nt) - in NT nt' args True - | otherwise = NT nt args False - -cataname :: String -> Identifier -> String -cataname pre name = pre++getName name - -conname :: Bool -> NontermIdent -> ConstructorIdent -> String -conname ren nt con | ren = capitalize (getName nt) ++ "_" ++ getName con - | otherwise = getName con - -capitalize :: String -> String -capitalize [] = [] -capitalize (c:cs) = toUpper c : cs - -semname :: String -> NontermIdent -> ConstructorIdent -> String -semname pre nt con = pre ++ (getName nt ++ "_" ++ getName con) - -recordFieldname :: NontermIdent -> ConstructorIdent -> Identifier -> String -recordFieldname nt con nm = getName nm ++ "_" ++ getName nt ++ "_" ++ getName con - -lhsname :: Options -> Bool -> Identifier -> String -lhsname opts isIn = attrname opts isIn _LHS - -attrname :: Options -> Bool -> Identifier -> Identifier -> String -attrname opts isIn field attr - | field == _LOC = locname opts attr - | field == _INST = instname attr - | field == _INST' = inst'name attr - | field == _FIELD = fieldname attr - | otherwise = let direction | isIn = "I" - | otherwise = "O" - pref = if clean opts then 'a' else '_' - in pref : getName field ++ direction ++ getName attr - -locname :: Options -> Identifier -> String -locname opts v = (if clean opts then 'l' else '_') : getName v - -instname, inst'name, fieldname :: Identifier -> String -instname v = getName v ++ "_val_" -inst'name v = getName v ++ "_inst_" -fieldname v = getName v++"_" - -typeToAGString :: Type -> String -typeToAGString tp - = case tp of - Haskell t -> t - NT nt tps for -> formatNonterminalToHaskell for (getName nt) (map (\s -> "{" ++ s ++ "}") tps) - Self -> error "Self type is not allowed here." - -removeDeforested :: Type -> Type -removeDeforested (NT nt args _) = NT nt args False -removeDeforested tp = tp - -forceDeforested :: Type -> Type -forceDeforested (NT nt args _) = NT nt args True -forceDeforested tp = tp - -typeToHaskellString :: Maybe NontermIdent -> [String] -> Type -> String -typeToHaskellString mbNt params tp - = case tp of - Haskell t -> filter (/= '@') t -- Apparently haskell types can contain @ to refer to - -- a type parameter, removing @ makes it backwards compatible - NT nt tps for | nt == _SELF -> formatNonterminalToHaskell for (maybe "?SELF?" getName mbNt) params - | otherwise -> formatNonterminalToHaskell for (getName nt) tps - Self -> maybe "?SELF?" getName mbNt - -formatNonterminalToHaskell :: Bool -> String -> [String] -> String -formatNonterminalToHaskell for nt tps - = unwords ((pref ++ nt) : tps) - where pref | for = "T_" - | otherwise = "" - -ind :: String -> String -ind s = replicate 3 ' ' ++ s - -_NOCASE :: Identifier -_NOCASE = identifier "nocase" - -hasPragma :: PragmaMap -> NontermIdent -> ConstructorIdent -> Identifier -> Bool -hasPragma mp nt con nm - = nm `Set.member` Map.findWithDefault Set.empty con (Map.findWithDefault Map.empty nt mp) - -isNonterminal :: Type -> Bool -isNonterminal (NT _ _ _) = True -isNonterminal _ = False - -isSELFNonterminal :: Type -> Bool --- isSELFNonterminal (NT nt _ _) | nt == _SELF = True -isSELFNonterminal Self = True -isSELFNonterminal _ = False - -extractNonterminal :: Type -> NontermIdent -extractNonterminal (NT n _ _) = n -extractNonterminal _ = error "Must be NT" - -nontermArgs :: Type -> [String] -nontermArgs tp - = case tp of - NT _ args _ -> args - _ -> [] - -deforestedNt :: Identifier -> Maybe Identifier -deforestedNt nm - | take 2 (getName nm) == "T_" = Just (Ident (drop 2 (getName nm)) (getPos nm)) - | otherwise = Nothing - -data StateCtx - = NoneVis - | OneVis !Int - | ManyVis - deriving (Eq, Show, Ord) - -data ChildKind - = ChildSyntax -- This child is defined by syntax - | ChildAttr -- This child is defined by an attribute - | ChildReplace Type -- This child replaces a child with type Type - deriving (Eq, Show) - --- Given a map that represents a relation, returns the transitive closure of this relation -closeMap :: Ord a => Map a (Set a) -> Map a (Set a) -closeMap mp0 = close (Map.keysSet mp0) mp0 where - rev = revDeps mp0 - close todo mp0' = case Set.minView todo of - Nothing -> mp0' - Just (k, todo1) -> let find x = Map.findWithDefault Set.empty x mp0' - vals0 = find k - valsL = Set.toList vals0 - vals1 = foldr Set.union vals0 $ map find valsL - in if Set.size vals0 == Set.size vals1 - then close todo1 mp0' -- note: monotonically increasing set - else let mp1 = Map.insert k vals1 mp0' - refs = Map.findWithDefault Set.empty k rev - todo2 = Set.union refs todo1 - in close todo2 mp1 - -revDeps :: Ord a => Map a (Set a) -> Map a (Set a) -revDeps mp = Map.fromListWith Set.union [ (a,Set.singleton k) | (k,s) <- Map.assocs mp, a <- Set.toList s ] - -data HigherOrderInfo = HigherOrderInfo - { hoNtDeps :: Set NontermIdent - , hoNtRevDeps :: Set NontermIdent - , hoAcyclic :: Bool - } - -data VisitKind - = VisitPure Bool -- ordered or not - | VisitMonadic - deriving (Eq,Ord) - -isLazyKind :: VisitKind -> Bool -isLazyKind (VisitPure False) = True -isLazyKind _ = False - -instance Show VisitKind where - show (VisitPure False) = "Lazy" - show (VisitPure True) = "Ordered" - show VisitMonadic = "Monadic" - -unionWithMappend :: (Monoid a, Ord k) => Map k a -> Map k a -> Map k a -unionWithMappend = Map.unionWith mappend - - -data FormatMode - = FormatDo - | FormatLetDecl - | FormatLetLine - deriving (Eq, Ord, Show) +module CommonTypes (module Options, module CommonTypes) where + +import Options +import UU.Scanner.Position(Pos) +import qualified Data.Map as Map +import Data.Map(Map) +import Data.Set(Set) +import qualified Data.Set as Set +import Data.Monoid(mappend,Monoid) +import Data.Char +import Pretty + +type Blocks = Map BlockInfo [([String], Pos)] +type BlockInfo = (BlockKind, Maybe NontermIdent) +data BlockKind + = BlockImport + | BlockPragma + | BlockMain + | BlockData + | BlockRec + | BlockOther + deriving (Eq, Ord, Show) + +instance PP Identifier where + pp = text . getName + +data Type = Haskell String + | NT Identifier [String] + Bool -- True: deforested nonterminal, False: nonterminal type + | Self -- reference to the enclosing nonterminal type + deriving (Eq) + +data ComplexType = List Type + | Tuple [(Identifier, Type)] + | Maybe Type + | Either Type Type + | Map Type Type + | IntMap Type + | OrdSet Type + | IntSet + +instance Show ComplexType where + show (List t ) = "[" ++ show t ++ "]" + show (Tuple ts) = "(" ++ showList [ show n ++ ": " ++ show t | (n,t) <- ts ] "" ++ ")" + show (Maybe t ) = "Maybe " ++ show t + show (Either t1 t2) = "Either " ++ show t1 ++ " " ++ show t2 + show (Map t1 t2) = "Map " ++ show t1 ++ " " ++ show t2 + show (IntMap t1) = "IntMap " ++ show t1 + show (OrdSet t1) = "Set" ++ show t1 + show IntSet = "IntSet" + +instance Show Type where + show = typeToHaskellString Nothing [] + +type Attributes = Map Identifier Type +type TypeSyns = [(NontermIdent,ComplexType)] +type ParamMap = Map NontermIdent [Identifier] +type AttrNames = [(Identifier,Type,(String,String,String))] +type UseMap = Map NontermIdent (Map Identifier (String,String,String)) +type PragmaMap = Map NontermIdent (Map ConstructorIdent (Set Identifier)) +type AttrMap = Map NontermIdent (Map ConstructorIdent (Set (Identifier,Identifier))) +type UniqueMap = Map NontermIdent (Map ConstructorIdent (Map Identifier Identifier)) +type Derivings = Map NontermIdent (Set Identifier) +type ClassContext = [(Identifier, [String])] +type ContextMap = Map NontermIdent ClassContext +type QuantMap = Map NontermIdent [String] +type Strings = [String] +type ConstructorIdent = Identifier +type AttrOrderMap = Map NontermIdent (Map ConstructorIdent (Set Dependency)) +type VisitIdentifier = Int +type StateIdentifier = Int +data Dependency = Dependency Occurrence Occurrence deriving (Eq,Ord,Show) +data Occurrence + = OccAttr Identifier Identifier + | OccRule Identifier + deriving (Eq,Ord,Show) +data ConstructorType + = DataConstructor + | RecordConstructor + deriving (Eq,Ord,Show) + +type AttrEnv = ( [Identifier] + , [(Identifier,Identifier)] + ) + +nullIdent, _LHS, _SELF, _LOC, _INST, _INST', _FIELD, _FIRST, _LAST :: Identifier +nullIdent = identifier "" +_LHS = identifier "lhs" +_SELF = identifier "SELF" +_LOC = identifier "loc" +_INST = identifier "inst" +_INST' = identifier "inst'" +_FIELD = identifier "field" +_FIRST = identifier "first__" +_LAST = identifier "last__" + +idLateBindingAttr :: Identifier +idLateBindingAttr = identifier "lateSemDict" + +lateBindingTypeNm :: String -> String +lateBindingTypeNm modNm = "Late_" ++ modNm ++ "_" + +lateBindingFieldNm :: String -> String +lateBindingFieldNm modNm = "late_" ++ modNm ++ "_" + +lateBindingType :: String -> Type +lateBindingType modNm = Haskell (lateBindingTypeNm modNm) + +lateSemNtLabel :: NontermIdent -> String +lateSemNtLabel nt = "mk_" ++ getName nt + +lateSemConLabel :: NontermIdent -> ConstructorIdent -> String +lateSemConLabel nt con = "mk_" ++ getName nt ++ "_" ++ getName con + +sdtype :: NontermIdent -> String +sdtype nt = "T_"++getName nt + +mkNtType :: Identifier -> [String] -> Type +mkNtType nt args + | take 2 (getName nt) == "T_" = let nt' = Ident (drop 2 (getName nt)) (getPos nt) + in NT nt' args True + | otherwise = NT nt args False + +cataname :: String -> Identifier -> String +cataname pre name = pre++getName name + +conname :: Bool -> NontermIdent -> ConstructorIdent -> String +conname ren nt con | ren = capitalize (getName nt) ++ "_" ++ getName con + | otherwise = getName con + +capitalize :: String -> String +capitalize [] = [] +capitalize (c:cs) = toUpper c : cs + +semname :: String -> NontermIdent -> ConstructorIdent -> String +semname pre nt con = pre ++ (getName nt ++ "_" ++ getName con) + +recordFieldname :: NontermIdent -> ConstructorIdent -> Identifier -> String +recordFieldname nt con nm = getName nm ++ "_" ++ getName nt ++ "_" ++ getName con + +lhsname :: Options -> Bool -> Identifier -> String +lhsname opts isIn = attrname opts isIn _LHS + +attrname :: Options -> Bool -> Identifier -> Identifier -> String +attrname opts isIn field attr + | field == _LOC = locname opts attr + | field == _INST = instname attr + | field == _INST' = inst'name attr + | field == _FIELD = fieldname attr + | otherwise = let direction | isIn = "I" + | otherwise = "O" + pref = if clean opts then 'a' else '_' + in pref : getName field ++ direction ++ getName attr + +locname :: Options -> Identifier -> String +locname opts v = (if clean opts then 'l' else '_') : getName v + +instname, inst'name, fieldname :: Identifier -> String +instname v = getName v ++ "_val_" +inst'name v = getName v ++ "_inst_" +fieldname v = getName v++"_" + +typeToAGString :: Type -> String +typeToAGString tp + = case tp of + Haskell t -> t + NT nt tps for -> formatNonterminalToHaskell for (getName nt) (map (\s -> "{" ++ s ++ "}") tps) + Self -> error "Self type is not allowed here." + +removeDeforested :: Type -> Type +removeDeforested (NT nt args _) = NT nt args False +removeDeforested tp = tp + +forceDeforested :: Type -> Type +forceDeforested (NT nt args _) = NT nt args True +forceDeforested tp = tp + +typeToHaskellString :: Maybe NontermIdent -> [String] -> Type -> String +typeToHaskellString mbNt params tp + = case tp of + Haskell t -> filter (/= '@') t -- Apparently haskell types can contain @ to refer to + -- a type parameter, removing @ makes it backwards compatible + NT nt tps for | nt == _SELF -> formatNonterminalToHaskell for (maybe "?SELF?" getName mbNt) params + | otherwise -> formatNonterminalToHaskell for (getName nt) tps + Self -> maybe "?SELF?" getName mbNt + +formatNonterminalToHaskell :: Bool -> String -> [String] -> String +formatNonterminalToHaskell for nt tps + = unwords ((pref ++ nt) : tps) + where pref | for = "T_" + | otherwise = "" + +ind :: String -> String +ind s = replicate 3 ' ' ++ s + +_NOCASE :: Identifier +_NOCASE = identifier "nocase" + +hasPragma :: PragmaMap -> NontermIdent -> ConstructorIdent -> Identifier -> Bool +hasPragma mp nt con nm + = nm `Set.member` Map.findWithDefault Set.empty con (Map.findWithDefault Map.empty nt mp) + +isNonterminal :: Type -> Bool +isNonterminal (NT _ _ _) = True +isNonterminal _ = False + +isSELFNonterminal :: Type -> Bool +-- isSELFNonterminal (NT nt _ _) | nt == _SELF = True +isSELFNonterminal Self = True +isSELFNonterminal _ = False + +extractNonterminal :: Type -> NontermIdent +extractNonterminal (NT n _ _) = n +extractNonterminal _ = error "Must be NT" + +nontermArgs :: Type -> [String] +nontermArgs tp + = case tp of + NT _ args _ -> args + _ -> [] + +deforestedNt :: Identifier -> Maybe Identifier +deforestedNt nm + | take 2 (getName nm) == "T_" = Just (Ident (drop 2 (getName nm)) (getPos nm)) + | otherwise = Nothing + +data StateCtx + = NoneVis + | OneVis !Int + | ManyVis + deriving (Eq, Show, Ord) + +data ChildKind + = ChildSyntax -- This child is defined by syntax + | ChildAttr -- This child is defined by an attribute + | ChildReplace Type -- This child replaces a child with type Type + deriving (Eq, Show) + +-- Given a map that represents a relation, returns the transitive closure of this relation +closeMap :: Ord a => Map a (Set a) -> Map a (Set a) +closeMap mp0 = close (Map.keysSet mp0) mp0 where + rev = revDeps mp0 + close todo mp0' = case Set.minView todo of + Nothing -> mp0' + Just (k, todo1) -> let find x = Map.findWithDefault Set.empty x mp0' + vals0 = find k + valsL = Set.toList vals0 + vals1 = foldr Set.union vals0 $ map find valsL + in if Set.size vals0 == Set.size vals1 + then close todo1 mp0' -- note: monotonically increasing set + else let mp1 = Map.insert k vals1 mp0' + refs = Map.findWithDefault Set.empty k rev + todo2 = Set.union refs todo1 + in close todo2 mp1 + +revDeps :: Ord a => Map a (Set a) -> Map a (Set a) +revDeps mp = Map.fromListWith Set.union [ (a,Set.singleton k) | (k,s) <- Map.assocs mp, a <- Set.toList s ] + +data HigherOrderInfo = HigherOrderInfo + { hoNtDeps :: Set NontermIdent + , hoNtRevDeps :: Set NontermIdent + , hoAcyclic :: Bool + } + +data VisitKind + = VisitPure Bool -- ordered or not + | VisitMonadic + deriving (Eq,Ord) + +isLazyKind :: VisitKind -> Bool +isLazyKind (VisitPure False) = True +isLazyKind _ = False + +instance Show VisitKind where + show (VisitPure False) = "Lazy" + show (VisitPure True) = "Ordered" + show VisitMonadic = "Monadic" + +unionWithMappend :: (Monoid a, Ord k) => Map k a -> Map k a -> Map k a +unionWithMappend = Map.unionWith mappend + + +data FormatMode + = FormatDo + | FormatLetDecl + | FormatLetLine + deriving (Eq, Ord, Show) diff --git a/src/GrammarInfo.hs b/src/GrammarInfo.hs --- a/src/GrammarInfo.hs +++ b/src/GrammarInfo.hs @@ -1,54 +1,54 @@ -module GrammarInfo where - -import SequentialTypes -import CodeSyntax -import Data.Map(Map) -import qualified Data.Map as Map -import Data.Set(Set) -import qualified Data.Set as Set -import CommonTypes -import Data.List(intersect,(\\)) -import Options - -type LMH = (Vertex,Vertex,Vertex) -data Info = Info { tdpToTds :: Table Vertex - , tdsToTdp :: Table [Vertex] - , attrTable :: Table NTAttr - , ruleTable :: Table CRule - , lmh :: [LMH] - , nonts :: [(NontermIdent,[ConstructorIdent])] - , wraps :: Set NontermIdent - } - deriving Show - -instance Show CRule - where show (CRule name _ _ nt con field childnt _ _ rhs _ _ _ uses _ _) - = "CRule " ++ show name ++ " nt: " ++ show nt ++ " con: " ++ show con ++ " field: " ++ show field - ++ " childnt: " ++ show childnt ++ " rhs: " ++ concat rhs ++ " uses: " ++ show [ attrname noOptions True fld nm | (fld,nm) <- Set.toList uses ] - show _ = error "Only CRule is supported" - -type CInterfaceMap = Map NontermIdent CInterface -type CVisitsMap = Map NontermIdent (Map ConstructorIdent CVisits) - -data CycleStatus - = CycleFree CInterfaceMap CVisitsMap - | LocalCycle [Route] - | InstCycle [Route] - | DirectCycle [EdgeRoutes] - | InducedCycle CInterfaceMap [EdgeRoutes] - -showsSegment :: CSegment -> [String] -showsSegment (CSegment inh syn) - = let syn' = map toString (Map.toList syn) - inh' = map toString (Map.toList inh) - toString (a,t) = (getName a, case t of (NT nt tps _) -> getName nt ++ " " ++ unwords tps; Haskell t' -> t'; Self -> error "Self type not supported.") - chnn = inh' `intersect` syn' - inhn = inh' \\ chnn - synn = syn' \\ chnn - disp _ [] = [] - disp name as = (name ++ if length as == 1 then " attribute:" else " attributes:") : - map (\(x,y) -> ind x ++ replicate ((20 - length x) `max` 0) ' ' ++ " : " ++ y) as - in disp "inherited" inhn - ++ disp "chained" chnn - ++ disp "synthesized" synn - +module GrammarInfo where + +import SequentialTypes +import CodeSyntax +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Set(Set) +import qualified Data.Set as Set +import CommonTypes +import Data.List(intersect,(\\)) +import Options + +type LMH = (Vertex,Vertex,Vertex) +data Info = Info { tdpToTds :: Table Vertex + , tdsToTdp :: Table [Vertex] + , attrTable :: Table NTAttr + , ruleTable :: Table CRule + , lmh :: [LMH] + , nonts :: [(NontermIdent,[ConstructorIdent])] + , wraps :: Set NontermIdent + } + deriving Show + +instance Show CRule + where show (CRule name _ _ nt con field childnt _ _ rhs _ _ _ uses _ _) + = "CRule " ++ show name ++ " nt: " ++ show nt ++ " con: " ++ show con ++ " field: " ++ show field + ++ " childnt: " ++ show childnt ++ " rhs: " ++ concat rhs ++ " uses: " ++ show [ attrname noOptions True fld nm | (fld,nm) <- Set.toList uses ] + show _ = error "Only CRule is supported" + +type CInterfaceMap = Map NontermIdent CInterface +type CVisitsMap = Map NontermIdent (Map ConstructorIdent CVisits) + +data CycleStatus + = CycleFree CInterfaceMap CVisitsMap + | LocalCycle [Route] + | InstCycle [Route] + | DirectCycle [EdgeRoutes] + | InducedCycle CInterfaceMap [EdgeRoutes] + +showsSegment :: CSegment -> [String] +showsSegment (CSegment inh syn) + = let syn' = map toString (Map.toList syn) + inh' = map toString (Map.toList inh) + toString (a,t) = (getName a, case t of (NT nt tps _) -> getName nt ++ " " ++ unwords tps; Haskell t' -> t'; Self -> error "Self type not supported.") + chnn = inh' `intersect` syn' + inhn = inh' \\ chnn + synn = syn' \\ chnn + disp _ [] = [] + disp name as = (name ++ if length as == 1 then " attribute:" else " attributes:") : + map (\(x,y) -> ind x ++ replicate ((20 - length x) `max` 0) ' ' ++ " : " ++ y) as + in disp "inherited" inhn + ++ disp "chained" chnn + ++ disp "synthesized" synn + diff --git a/src/HsTokenScanner.hs b/src/HsTokenScanner.hs --- a/src/HsTokenScanner.hs +++ b/src/HsTokenScanner.hs @@ -1,194 +1,194 @@ - -module HsTokenScanner where -import HsToken -import UU.Scanner.Position -import Data.List(sort) -import UU.Util.BinaryTrees -import CommonTypes -import Data.Maybe -import Data.Char - -isAGesc :: Char -> Bool -isAGesc c = c == '@' - -lexTokens :: Options -> Pos -> String -> [HsToken] -lexTokens = scanTokens keywordstxt keywordsops specialchars opchars - where keywordstxt = [] - keywordsops = [".","=", ":=", ":","|","@"] - specialchars = ";()[],_{}`" - opchars = "!#$%&*+./<=>?@\\^|-~:" - - -scanTokens :: [String] -> [String] -> String -> String -> Options -> Pos -> String -> [HsToken] -scanTokens keywordstxt keywordsops specchars opchars opts pos input - = doScan pos input - - where - locatein :: Ord a => [a] -> a -> Bool - locatein es = isJust . btLocateIn compare (tab2tree (sort es)) - iskw = locatein keywordstxt - isop = locatein keywordsops - isSymb = locatein specchars - -- See http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators - isOpsym c = locatein opchars c - -- For unicode operators - || (not (isAscii c) && (isSymbol c || isPunctuation c)) - - isIdStart c = isLower c || c == '_' - - isIdChar c = isAlphaNum c - || c == '\'' - || c == '_' - - scanIdent p s = let (name,rest) = span isIdChar s - in (name,advc (length name) p,rest) - - doScan _ [] = [] - doScan p (c:s) | isSpace c = let (sp,next) = span isSpace s - in doScan (foldl (flip updPos) p (c:sp)) next - doScan p (c:d:s) | isAGesc c && isIdStart d = - let (fld,p2,rest) = scanIdent (advc 2 p) s - field = d:fld - in case rest of - ('.':r:rs) - | isIdStart r -> let (at,p3,rest2) = scanIdent (advc 2 p2) rs - attr = r : at - in AGField (Ident field p) (Ident attr p) p Nothing : doScan p3 rest2 - _ -> AGLocal (Ident field p) p Nothing : doScan p2 rest - - doScan p ('/':'/':s) | clean opts = doScan p (dropWhile (/= '\n') s) - doScan p ('/':'*':s) | clean opts = advc' 2 p (lexCleanNest doScan) s -- } - doScan p ('-':'-':s) = doScan p (dropWhile (/= '\n') s) - doScan p ('{':'-':s) = advc' 2 p (lexNest doScan) s -- } - doScan p ('"':ss) - = let (s,swidth,rest) = scanString ss - in if null rest || head rest /= '"' - then Err "Unterminated string literal" p : advc' swidth p doScan rest - else StrToken s p : advc' (swidth+2) p doScan (tail rest) - - doScan p ('\'':ss) - | clean opts = let (str,nswidth,rest) = scanQualName ss - in HsToken ('\'' : str ++ "'") p : advc' (nswidth + 2) p doScan (tail rest) - | otherwise - = let (mc,cwidth,rest) = scanChar ss - in case mc of - Nothing -> Err "Error in character literal" p : advc' cwidth p doScan rest - Just c -> if null rest || head rest /= '\'' - then Err "Unterminated character literal" p : advc' (cwidth+1) p doScan rest - else CharToken [c] p : advc' (cwidth+2) p doScan (tail rest) - doScan p cs@(c:s) - - | isIdStart c || isUpper c - = let (name', p', s') = scanIdent (advc 1 p) s - name = c:name' - tok = if iskw name - then HsToken name p -- keyword - else if null name' && isSymb c - then HsToken [c] p -- '_' - else HsToken name p -- varid / conid - in tok : doScan p' s' - | isOpsym c = let (name, s') = span isOpsym cs - tok | isop name = HsToken name p - | otherwise = HsToken name p - in tok : doScan (foldl (flip updPos) p name) s' - | isDigit c = let (base,digs,width,s') = getNumber cs - number = case base of - 8 -> "0o"++digs - 10 -> digs - 16 -> "0x"++digs - _ -> error $ "Base " ++ show base ++ " is not supported." - in HsToken number p : advc' width p doScan s' - | isSymb c = HsToken [c] p : advc' 1 p doScan s - | otherwise = Err ("Unexpected character " ++ show c) p : updPos' c p doScan s - -lexNest :: (Pos -> String -> [HsToken]) -> Pos -> String -> [HsToken] -lexNest cont pos inp = lexNest' cont pos inp - where lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s - lexNest' c p ('-':'}':s) = c (advc 2 p) s - lexNest' c p (x:s) = lexNest' c (updPos x p) s - lexNest' _ _ [] = [Err "Unterminated nested comment" pos] - -lexCleanNest :: (Pos -> String -> [HsToken]) -> Pos -> String -> [HsToken] -lexCleanNest cont pos inp = lexNest' cont pos inp - where lexNest' c p ('/':'*':s) = lexNest' (lexNest' c) (advc 2 p) s - lexNest' c p ('*':'/':s) = c (advc 2 p) s - lexNest' c p (x:s) = lexNest' c (updPos x p) s - lexNest' _ _ [] = [Err "Unterminated nested comment" pos] - -scanString :: String -> (String, Int, String) -scanString [] = ("",0,[]) -scanString ('\\':'&':xs) = let (str,w,r) = scanString xs - in (str,w+2,r) -scanString ('\'':xs) = let (str,w,r) = scanString xs - in ('\'': str,w+1,r) -scanString xs = let (ch,cw,cr) = getchar xs - (str,w,r) = scanString cr --- str' = maybe "" (:str) ch - in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch - -scanQualName :: String -> (String, Int, String) -scanQualName [] = ("",0,[]) -scanQualName r@('\'':_) = ("",0,r) -scanQualName xs = let (ch,cw,cr) = getchar xs - (str,w,r) = scanQualName cr - in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch - -scanChar :: String -> (Maybe Char, Int, String) -scanChar ('"' :xs) = (Just '"',1,xs) -scanChar xs = getchar xs - -getchar :: String -> (Maybe Char, Int, String) -getchar [] = (Nothing,0,[]) -getchar s@('\n':_ ) = (Nothing,0,s ) -getchar s@('\t':_ ) = (Nothing,0,s) -getchar s@('\'':_ ) = (Nothing,0,s) -getchar s@('"' :_ ) = (Nothing,0,s) -getchar ('\\':xs) = let (c,l,r) = getEscChar xs - in (c,l+1,r) -getchar (x:xs) = (Just x,1,xs) - -getEscChar :: String -> (Maybe Char, Int, String) -getEscChar [] = (Nothing,0,[]) -getEscChar s@(x:xs) | isDigit x = let (base,n,len,rest) = getNumber s - val = readn base n - in if val >= 0 && val <= 255 - then (Just (chr val),len, rest) - else (Nothing,1,rest) - | otherwise = case x `lookup` cntrChars of - Nothing -> (Nothing,0,s) - Just c -> (Just c,1,xs) - where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t') - ,('v','\v'),('\\','\\'),('"','\"'),('\'','\'')] - -readn :: Int -> String -> Int -readn base n = foldl (\r x -> value x + base * r) 0 n - -getNumber :: String -> (Int,String,Int,String) -getNumber [] = error "Empty string" -getNumber cs@(c:s) - | c /= '0' = num10 - | null s = const0 - | hs == 'x' || hs == 'X' = num16 - | hs == 'o' || hs == 'O' = num8 - | otherwise = num10 - where (hs:ts) = s - const0 = (10, "0",1,s) - num10 = let (n,r) = span isDigit cs - in (10,n,length n,r) - num16 = readNum isHexaDigit ts 16 - num8 = readNum isOctalDigit ts 8 - readNum p ts' tk - = let (n,rs) = span p ts' - in if null n then const0 - else (tk, n, 2+length n,rs) - -isHexaDigit :: Char -> Bool -isHexaDigit d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f') -isOctalDigit :: Char -> Bool -isOctalDigit d = d >= '0' && d <= '7' - -value :: Char -> Int -value c | isDigit c = ord c - ord '0' - | isUpper c = ord c - ord 'A' + 10 - | isLower c = ord c - ord 'a' + 10 -value _ = error "Not a valid value" + +module HsTokenScanner where +import HsToken +import UU.Scanner.Position +import Data.List(sort) +import UU.Util.BinaryTrees +import CommonTypes +import Data.Maybe +import Data.Char + +isAGesc :: Char -> Bool +isAGesc c = c == '@' + +lexTokens :: Options -> Pos -> String -> [HsToken] +lexTokens = scanTokens keywordstxt keywordsops specialchars opchars + where keywordstxt = [] + keywordsops = [".","=", ":=", ":","|","@"] + specialchars = ";()[],_{}`" + opchars = "!#$%&*+./<=>?@\\^|-~:" + + +scanTokens :: [String] -> [String] -> String -> String -> Options -> Pos -> String -> [HsToken] +scanTokens keywordstxt keywordsops specchars opchars opts pos input + = doScan pos input + + where + locatein :: Ord a => [a] -> a -> Bool + locatein es = isJust . btLocateIn compare (tab2tree (sort es)) + iskw = locatein keywordstxt + isop = locatein keywordsops + isSymb = locatein specchars + -- See http://stackoverflow.com/questions/10548170/what-characters-are-permitted-for-haskell-operators + isOpsym c = locatein opchars c + -- For unicode operators + || (not (isAscii c) && (isSymbol c || isPunctuation c)) + + isIdStart c = isLower c || c == '_' + + isIdChar c = isAlphaNum c + || c == '\'' + || c == '_' + + scanIdent p s = let (name,rest) = span isIdChar s + in (name,advc (length name) p,rest) + + doScan _ [] = [] + doScan p (c:s) | isSpace c = let (sp,next) = span isSpace s + in doScan (foldl (flip updPos) p (c:sp)) next + doScan p (c:d:s) | isAGesc c && isIdStart d = + let (fld,p2,rest) = scanIdent (advc 2 p) s + field = d:fld + in case rest of + ('.':r:rs) + | isIdStart r -> let (at,p3,rest2) = scanIdent (advc 2 p2) rs + attr = r : at + in AGField (Ident field p) (Ident attr p) p Nothing : doScan p3 rest2 + _ -> AGLocal (Ident field p) p Nothing : doScan p2 rest + + doScan p ('/':'/':s) | clean opts = doScan p (dropWhile (/= '\n') s) + doScan p ('/':'*':s) | clean opts = advc' 2 p (lexCleanNest doScan) s -- } + doScan p ('-':'-':s) = doScan p (dropWhile (/= '\n') s) + doScan p ('{':'-':s) = advc' 2 p (lexNest doScan) s -- } + doScan p ('"':ss) + = let (s,swidth,rest) = scanString ss + in if null rest || head rest /= '"' + then Err "Unterminated string literal" p : advc' swidth p doScan rest + else StrToken s p : advc' (swidth+2) p doScan (tail rest) + + doScan p ('\'':ss) + | clean opts = let (str,nswidth,rest) = scanQualName ss + in HsToken ('\'' : str ++ "'") p : advc' (nswidth + 2) p doScan (tail rest) + | otherwise + = let (mc,cwidth,rest) = scanChar ss + in case mc of + Nothing -> Err "Error in character literal" p : advc' cwidth p doScan rest + Just c -> if null rest || head rest /= '\'' + then Err "Unterminated character literal" p : advc' (cwidth+1) p doScan rest + else CharToken [c] p : advc' (cwidth+2) p doScan (tail rest) + doScan p cs@(c:s) + + | isIdStart c || isUpper c + = let (name', p', s') = scanIdent (advc 1 p) s + name = c:name' + tok = if iskw name + then HsToken name p -- keyword + else if null name' && isSymb c + then HsToken [c] p -- '_' + else HsToken name p -- varid / conid + in tok : doScan p' s' + | isOpsym c = let (name, s') = span isOpsym cs + tok | isop name = HsToken name p + | otherwise = HsToken name p + in tok : doScan (foldl (flip updPos) p name) s' + | isDigit c = let (base,digs,width,s') = getNumber cs + number = case base of + 8 -> "0o"++digs + 10 -> digs + 16 -> "0x"++digs + _ -> error $ "Base " ++ show base ++ " is not supported." + in HsToken number p : advc' width p doScan s' + | isSymb c = HsToken [c] p : advc' 1 p doScan s + | otherwise = Err ("Unexpected character " ++ show c) p : updPos' c p doScan s + +lexNest :: (Pos -> String -> [HsToken]) -> Pos -> String -> [HsToken] +lexNest cont pos inp = lexNest' cont pos inp + where lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s + lexNest' c p ('-':'}':s) = c (advc 2 p) s + lexNest' c p (x:s) = lexNest' c (updPos x p) s + lexNest' _ _ [] = [Err "Unterminated nested comment" pos] + +lexCleanNest :: (Pos -> String -> [HsToken]) -> Pos -> String -> [HsToken] +lexCleanNest cont pos inp = lexNest' cont pos inp + where lexNest' c p ('/':'*':s) = lexNest' (lexNest' c) (advc 2 p) s + lexNest' c p ('*':'/':s) = c (advc 2 p) s + lexNest' c p (x:s) = lexNest' c (updPos x p) s + lexNest' _ _ [] = [Err "Unterminated nested comment" pos] + +scanString :: String -> (String, Int, String) +scanString [] = ("",0,[]) +scanString ('\\':'&':xs) = let (str,w,r) = scanString xs + in (str,w+2,r) +scanString ('\'':xs) = let (str,w,r) = scanString xs + in ('\'': str,w+1,r) +scanString xs = let (ch,cw,cr) = getchar xs + (str,w,r) = scanString cr +-- str' = maybe "" (:str) ch + in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch + +scanQualName :: String -> (String, Int, String) +scanQualName [] = ("",0,[]) +scanQualName r@('\'':_) = ("",0,r) +scanQualName xs = let (ch,cw,cr) = getchar xs + (str,w,r) = scanQualName cr + in maybe ("",0,xs) (\c -> (c:str,cw+w,r)) ch + +scanChar :: String -> (Maybe Char, Int, String) +scanChar ('"' :xs) = (Just '"',1,xs) +scanChar xs = getchar xs + +getchar :: String -> (Maybe Char, Int, String) +getchar [] = (Nothing,0,[]) +getchar s@('\n':_ ) = (Nothing,0,s ) +getchar s@('\t':_ ) = (Nothing,0,s) +getchar s@('\'':_ ) = (Nothing,0,s) +getchar s@('"' :_ ) = (Nothing,0,s) +getchar ('\\':xs) = let (c,l,r) = getEscChar xs + in (c,l+1,r) +getchar (x:xs) = (Just x,1,xs) + +getEscChar :: String -> (Maybe Char, Int, String) +getEscChar [] = (Nothing,0,[]) +getEscChar s@(x:xs) | isDigit x = let (base,n,len,rest) = getNumber s + val = readn base n + in if val >= 0 && val <= 255 + then (Just (chr val),len, rest) + else (Nothing,1,rest) + | otherwise = case x `lookup` cntrChars of + Nothing -> (Nothing,0,s) + Just c -> (Just c,1,xs) + where cntrChars = [('a','\a'),('b','\b'),('f','\f'),('n','\n'),('r','\r'),('t','\t') + ,('v','\v'),('\\','\\'),('"','\"'),('\'','\'')] + +readn :: Int -> String -> Int +readn base n = foldl (\r x -> value x + base * r) 0 n + +getNumber :: String -> (Int,String,Int,String) +getNumber [] = error "Empty string" +getNumber cs@(c:s) + | c /= '0' = num10 + | null s = const0 + | hs == 'x' || hs == 'X' = num16 + | hs == 'o' || hs == 'O' = num8 + | otherwise = num10 + where (hs:ts) = s + const0 = (10, "0",1,s) + num10 = let (n,r) = span isDigit cs + in (10,n,length n,r) + num16 = readNum isHexaDigit ts 16 + num8 = readNum isOctalDigit ts 8 + readNum p ts' tk + = let (n,rs) = span p ts' + in if null n then const0 + else (tk, n, 2+length n,rs) + +isHexaDigit :: Char -> Bool +isHexaDigit d = isDigit d || (d >= 'A' && d <= 'F') || (d >= 'a' && d <= 'f') +isOctalDigit :: Char -> Bool +isOctalDigit d = d >= '0' && d <= '7' + +value :: Char -> Int +value c | isDigit c = ord c - ord '0' + | isUpper c = ord c - ord 'A' + 10 + | isLower c = ord c - ord 'a' + 10 +value _ = error "Not a valid value" diff --git a/src/KennedyWarren.hs b/src/KennedyWarren.hs --- a/src/KennedyWarren.hs +++ b/src/KennedyWarren.hs @@ -1,850 +1,851 @@ -module KennedyWarren where - -import Prelude hiding (init, succ) -import CommonTypes -import Pretty -import Knuth1 -import ExecutionPlan -import Debug.Trace -import Control.Monad.ST -import Control.Monad.State -import Control.Monad.Error -import Data.STRef -import Data.Maybe -import Data.List (intersperse, groupBy, partition, sortBy) -import Data.Ord -import qualified ErrorMessages as Err -import PrintErrorMessages () - -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Map.Strict as MapStrict -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - --- lazy version (does not return errors) --- FIXME: construct map from nonterminal to intial visit (or state?) and use it in the generation of invokes -kennedyWarrenLazy :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> ExecutionPlan -kennedyWarrenLazy _ wr ndis typesyns derivings = plan where - plan = ExecutionPlan nonts typesyns wr derivings - nonts = zipWith mkNont ndis nontIds - nontIds = enumFromThen 1 4 - initvMap = Map.fromList $ zipWith (\ndi initv -> (ndiNonterminal ndi, initv)) ndis nontIds - - mkNont ndi initv = nont where - nont = ENonterminal - (ndiNonterminal ndi) - (ndiParams ndi) - (ndiClassCtxs ndi) - initst - [initv] - nextMap - prevMap - prods - (ndiRecursive ndi) - (ndiHoInfo ndi) - initst = initv + 1 - finals = initv + 2 - nextMap = Map.fromList [(initst, OneVis initv), (finals, NoneVis)] - prevMap = Map.fromList [(initst, NoneVis), (finals, OneVis initv)] - prods = map mkProd (ndiProds ndi) - - mkProd pdi = prod where - prod = EProduction - (pdgProduction pdi) - (pdgParams pdi) - (pdgConstraints pdi) - (pdgRules pdi) - (pdgChilds pdi) - visits - visits = [vis] - vis = Visit initv initst finals inh syn steps kind - inh = Set.fromList $ ndiInh ndi - syn = Set.fromList $ ndiSyn ndi - kind = VisitPure False - steps = childSteps ++ invokeSteps ++ ruleSteps - - childSteps = [ ChildIntro nm | EChild nm _ _ _ _ _ <- pdgChilds pdi ] - invokeSteps = [ ChildVisit nm nt v - | EChild nm tp _ _ _ _ <- pdgChilds pdi - , let nt = extractNonterminal tp - v = Map.findWithDefault (error "child not in initv-map") nt initvMap - ] - ruleSteps = [ Sem nm | (ERule nm _ _ _ _ _ _ _) <- pdgRules pdi ] - - --- ordered version (may return errors) -kennedyWarrenOrder :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> Either Err.Error (ExecutionPlan, PP_Doc, PP_Doc) -kennedyWarrenOrder opts wr ndis typesyns derivings = runST $ runErrorT $ do - indi <- lift $ mapM mkNontDependencyInformationM ndis - lift $ knuth1 indi - -- Check all graphs for cyclicity, transitive closure and consistency - -- traceST $ "Checking graphs..." - forM_ indi $ \ndi -> do - let nont = ndiNonterminal . ndimOrig $ ndi - let g = ndgmDepGraph . ndimDepGraph $ ndi - -- Topological sort - --tsedg <- graphTopSort g - -- Cyclicity check - ntCycVerts <- lift $ graphCyclicVerticesExt g - when (not $ null ntCycVerts) $ do - throwError $ Err.Cyclic nont Nothing (map show ntCycVerts) --- let msg = "Nonterminal graph " ++ show nont ++ " is cylic!" --- fail msg - -- Transtive closure check - trc <- lift $ graphIsTRC g - when (not trc) $ do - let msg = "Nonterminal graph " ++ show nont ++ " is not transitively closed!" - fail msg - -- Consistency check - cons <- lift $ graphCheckConsistency g - when (not cons) $ do - let msg = "Nonterminal graph " ++ show nont ++ " is not consistent!" - fail msg - - -- Loop trough all productions - forM_ (ndimProds ndi) $ \prod -> do - let pr = pdgProduction $ pdgmOrig prod - let g' = pdgmDepGraph $ prod - -- Topsort - --addTopSortEdges tsedg prod - -- Check for cyclicity - pdCycVerts <- lift $ graphCyclicVerticesExt g' - when (not $ null pdCycVerts) $ do - throwError $ Err.Cyclic nont (Just pr) (map show pdCycVerts) - -- let msg = "Production graph " ++ show pr ++ " of nonterminal " - -- ++ show nont ++ " is cylic!" - -- fail msg - -- Transtive closure check - trc' <- lift $ graphIsTRC g' - when (not trc') $ do - lift $ traceST $ "Production graph " ++ show pr ++ " of nonterminal " - ++ show nont ++ " is not transitively closed!" - fail "Production graph is not transitively closed." - -- Check consistency - consistent <- lift $ graphCheckConsistency g' - when (not consistent) $ do - let msg = "Production graph " ++ show pr ++ " of nonterminal " - ++ show nont ++ " is not consistent!" - fail msg - -- reachable when everything is ok - lift $ do - -- Create non-transitive closed graph for efficiency - indi' <- undoTransitiveClosure indi - -- Graphviz output of dependency graphs - gvs <- mapM toGVNontDependencyInfo indi' - -- Doing kennedywarren - (ret, visitg) <- runVG $ do - -- traceVG $ "Running kennedy-warren..." - initvs <- kennedyWarrenVisitM wr indi' - -- Print some debug info - nodes <- gets vgNodeNum - edges <- gets vgEdgeNum - when (not $ beQuiet opts) $ do - traceVG $ "Number of nodes = " ++ show nodes - traceVG $ "Number of edges = " ++ show edges - -- Generate execution plan - ex <- kennedyWarrenExecutionPlan opts indi' initvs wr typesyns derivings - -- Get visit graph - visitg <- toGVVisitGraph - return (ex,visitg) - -- Return the result - return (ret, vlist gvs, visitg) - -------------------------------------------------------------------------------- --- Debugging functionality -------------------------------------------------------------------------------- - --- | Pretty print a vertex in GraphViz format -toGVVertex :: Bool -> Vertex -> ST s PP_Doc -toGVVertex l (VAttr t a b) = return $ (text $ "attr_" ++ show t ++ "_" ++ show a ++ "_" ++ show b) >#< if l - then text ("[shape=box,label=\"" ++ show t ++ " @" ++ show a ++ "." ++ show b ++ "\"]") else empty -toGVVertex l (VChild c) = return $ (text $ "child_" ++ show c) >#< if l - then text ("[shape=ellipse,label=\"Child " ++ show c ++ "\"]") else empty -toGVVertex l (VRule r) = return $ (text $ "rule_" ++ show r) >#< if l - then text ("[shape=diamond,label=\"" ++ show r ++ "\"]") else empty - --- | Pretty print an edge in GraphViz format -toGVEdge :: Edge -> ST s PP_Doc -toGVEdge (v1, v2) = do r1 <- toGVVertex False v1 - r2 <- toGVVertex False v2 - return $ r1 >|< text "->" >#< r2 - --- | Pretty print a NontDependencyInformation in GraphViz format -toGVNontDependencyInfo :: NontDependencyInformationM s -> ST s PP_Doc -toGVNontDependencyInfo ndi = do dg <- return $ ndgmDepGraph . ndimDepGraph $ ndi - verts <- graphVertices dg - edges <- graphEdges dg - vtexts <- mapM (toGVVertex True) verts - etexts <- mapM toGVEdge edges - ptexts <- mapM toGVProdDependencyGraph (ndimProds ndi) - return $ (text ("digraph ndg_" ++ show (ndiNonterminal $ ndimOrig ndi) ++ " {") - >-< - vlist vtexts - >-< - vlist etexts - >-< - text "}" - >-< - text "" -- empty line - >-< - vlist ptexts) - --- | Pretty print a ProdDependencyGraph in GraphViz format -toGVProdDependencyGraph :: ProdDependencyGraphM s -> ST s PP_Doc -toGVProdDependencyGraph pdg = do dg <- return $ pdgmDepGraph pdg - verts <- graphVertices dg - edges <- graphEdges dg - vtexts <- mapM (toGVVertex True) verts - etexts <- mapM toGVEdge edges - return $ (text ("digraph pdg_" ++ show (pdgProduction $ pdgmOrig pdg) ++ " {") - >-< - (vlist vtexts) - >-< - (vlist etexts) - >-< - text ("info [shape=box,label=\"" ++ show (pdgChildMap $ pdgmOrig pdg) ++ "\"];") - >-< - text "}" - >-< - text "") - -toGVVisitGraph :: VG s PP_Doc -toGVVisitGraph = do - ndis <- gets vgNDI - noded <- forM (IntMap.toList ndis) $ \(n,rndi) -> do - ndi <- vgInST $ readSTRef rndi - return $ "node_" >|< n >#< "[label=\"" >|< ndiNonterminal (ndimOrig ndi) >|< "_" >|< n >|< "\"];" - edges <- gets vgEdges - edged <- forM (IntMap.toList edges) $ \(edg,(VGNode from,VGNode to)) -> do - inh <- getInherited (VGEdge edg) - syn <- getSynthesized (VGEdge edg) - return $ "node_" >|< from >#< "-> node_" >|< to >#< "[label=\"visit v" >|< edg - >|< "\\ninh:" >#< (concat $ intersperse ", " $ map show $ Set.toList inh) >|< "\\nsyn: " >|< (concat $ intersperse ", " $ map show $ Set.toList syn) >|< "\"];" - return $ "digraph visitgraph { " >-< vlist noded >-< vlist edged >-< "}" - -------------------------------------------------------------------------------- --- Kennedy-Warren in monadic style -------------------------------------------------------------------------------- -{- -runVG :: VG s a -> ST s a -insertInitialNode :: NontDependencyInformationM s -> VG s VGNode -createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge -selectPending :: VG s VGEdge -getInherited :: VGEdge -> VG s (Set Identifier) -getSynthesized :: VGEdge -> VG s (Set Identifier) -markFinal :: VGEdge -> VG s () -getProductions :: VGEdge -> VG s [VGProd] -onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a -isDepGraphVertexFinal :: VGProd -> Vertex -> VG s Bool -setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s () -getChildState :: VGProd -> Identifier -> VG s VGNode -addChildVisit :: VGProd -> Identifier -> VGEdge -> VG s VisitStep -addVisitStep :: VGProd -> VisitStep -> VG s () -repeatM :: VG s () -> VG s () --} - -newtype VGNode = VGNode Int deriving (Show,Eq,Ord) -newtype VGEdge = VGEdge Int deriving (Show,Eq,Ord) -newtype VGProd = VGProd (VGEdge,Int) deriving (Show,Eq,Ord) - -data VGState s = VGState { vgNodeNum :: Int - , vgEdgeNum :: Int - -- Node maps - , vgOutgoing :: IntMap (STRef s (Set VGEdge)) - , vgIncoming :: IntMap (Maybe VGEdge) - , vgNDI :: IntMap (STRef s (NontDependencyInformationM s)) - , vgInhSynNode :: Map (Identifier, Set Identifier, Set Identifier) VGNode - , vgNodeInhSyn :: IntMap (Set Identifier, Set Identifier) - , vgInitial :: Map Identifier VGNode - -- Edge maps - , vgEdges :: IntMap (VGNode, VGNode) - , vgEdgesR :: Map (VGNode,VGNode) VGEdge - , vgInherited :: IntMap (Set Identifier) - , vgSynthesized :: IntMap (Set Identifier) - , vgPending :: IntSet - , vgChildVisits :: IntMap (STRef s (Map (Identifier,Int) [VGNode])) - -- Final vertices in production graphs - , vgFinalVertices :: IntMap (STRef s (Set (Vertex,Int))) - -- Construction of execution plan (Nonterminal,Production,Visit) - , vgProdVisits :: Map (Identifier,Identifier,VGEdge) (STRef s [VisitStep]) - } - -type VG s a = ErrorT String (StateT (VGState s) (ST s)) a - ------------------------------------------------------------- ---- Public functions --- ------------------------------------------------------------- --- | Run the VG monad in the ST monad -runVG :: VG s a -> ST s a -runVG vg = do (Right a,_) <- runStateT (runErrorT vg) vgEmptyState - return a - --- | Insert an initial node for this nonterminal into the visit graph -insertInitialNode :: NontDependencyInformationM s -> VG s VGNode -insertInitialNode ndi = do - rndi <- vgInST $ newSTRef ndi - (VGNode node) <- vgCreateNode rndi Set.empty Set.empty - initial <- gets vgInitial - incoming <- gets vgIncoming - modify $ \st -> st { vgInitial = Map.insert (ndiNonterminal $ ndimOrig ndi) (VGNode node) initial - , vgIncoming = IntMap.insert node Nothing incoming } - return (VGNode node) - --- | Create a pending edge from this node with a set of inherited and synthesized attributes -createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge -createPending vgn@(VGNode n) inh syn = do - -- Check if target node already exists - ninhsyn <- gets vgNodeInhSyn - let (pinh,psyn) = imLookup n ninhsyn - let ninh = Set.union pinh inh - let nsyn = Set.union psyn syn - mndi <- gets vgNDI - let rndi = imLookup n mndi - ndi <- vgInST $ readSTRef rndi - inhsynn <- gets vgInhSynNode - case Map.lookup (ndiNonterminal $ ndimOrig ndi, ninh, nsyn) inhsynn of - Just tn -> do - when (tn == vgn) $ do traceVG $ "Source and target nodes are the same!" - traceVG $ "Maybe there is a wrapper with no inherited or synthesized attributes." - traceVG $ "Inh: " ++ show inh - traceVG $ "Syn: " ++ show syn - traceVG $ "PInh: " ++ show pinh - traceVG $ "PSyn: " ++ show psyn - -- tn is target node, now check if edge exists and create if not - edgesr <- gets vgEdgesR - case Map.lookup (vgn,tn) edgesr of - Just e -> return e - Nothing -> vgCreatePendingEdge vgn tn inh syn - Nothing -> do - -- target node does not exist, create it and then create the new edge - tn <- vgCreateNode rndi ninh nsyn - vgCreatePendingEdge vgn tn inh syn - --- | Return an arbitrary pending edge of which the from node is ready -selectPending :: VG s VGEdge -selectPending = do - pending <- gets vgPending - incoming <- gets vgIncoming - edges <- gets vgEdges - let readyPend = filter (\p -> let (VGNode fr,_) = imLookup p edges - in isJust $ IntMap.lookup fr incoming) $ IntSet.toList pending - guard $ not $ null readyPend - return $ VGEdge $ head $ readyPend - --- | Get the inherited attributes of an edge -getInherited :: VGEdge -> VG s (Set Identifier) -getInherited (VGEdge edg) = do - inhs <- gets vgInherited - return $ imLookup edg inhs - --- | Get the synthesized attributes of an edge -getSynthesized :: VGEdge -> VG s (Set Identifier) -getSynthesized (VGEdge edg) = do - syns <- gets vgSynthesized - return $ imLookup edg syns - --- | Mark an edge as final -markFinal :: VGEdge -> VG s () -markFinal vgedg@(VGEdge edg) = do - incoming <- gets vgIncoming - edges <- gets vgEdges - pending <- gets vgPending - let (_,VGNode to) = imLookup edg edges - modify $ \st -> st { vgIncoming = IntMap.insert to (Just vgedg) incoming - , vgPending = IntSet.delete edg pending } - --- | Get all productions for an edge -getProductions :: VGEdge -> VG s [VGProd] -getProductions vedg@(VGEdge edg) = do - edges <- gets vgEdges - let (VGNode fr,_) = imLookup edg edges - ndis <- gets vgNDI - let rndi = imLookup fr ndis - ndi <- vgInST $ readSTRef rndi - return $ map (\x -> VGProd (vedg,x)) [0..(length $ ndimProds ndi)-1] - --- | Execute a function on the dependency graph for this production -onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a -onMarkedDepGraph f (VGProd (VGEdge edg, n)) = do - edges <- gets vgEdges - let (VGNode fr,_) = imLookup edg edges - ndis <- gets vgNDI - let rndi = imLookup fr ndis - ndi <- vgInST $ readSTRef rndi - vgInST $ f $ (ndimProds ndi) !! n -- not efficient, but lists are usually short - --- | Check whether this vertex has been marked as final -isDepGraphVertexFinal :: VGProd -> Vertex -> VG s Bool -isDepGraphVertexFinal (VGProd (VGEdge edg, p)) v = do - edges <- gets vgEdges - let (from,_) = imLookup edg edges - vgDepGraphVertexFinal from p v - --- | Mark these vertices final in this production -setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s () -setDepGraphVerticesFinal (VGProd (VGEdge edg, p)) vs = do - edges <- gets vgEdges - let (_,VGNode to) = imLookup edg edges - finalv <- gets vgFinalVertices - let rfinalv = imLookup to finalv - vgInST $ modifySTRef rfinalv $ Set.union (Set.fromList $ map (\v -> (v,p)) vs) - --- | Add a child visit to this production and return the step for the execution plan -addChildVisit :: VGProd -> Identifier -> VGEdge -> VG s VisitStep -addChildVisit (VGProd (VGEdge edg, p)) ide (VGEdge vs) = do - edges <- gets vgEdges - let (VGNode from,vgto) = imLookup vs edges -- from must be equal to the current state - childvs <- gets vgChildVisits - let rchildv = imLookup edg childvs - vgInST $ modifySTRef rchildv $ MapStrict.insertWith (++) (ide,p) [vgto] - ndis <- gets vgNDI - let rndi = imLookup from ndis - ndi <- vgInST $ readSTRef rndi - let nt = ndiNonterminal $ ndimOrig ndi - return $ ChildVisit ide nt vs - --- | Add a step to the execution plan of this visit -addVisitStep :: VGProd -> VisitStep -> VG s () -addVisitStep (VGProd (VGEdge edg, p)) st = do - edges <- gets vgEdges - let (VGNode fr,_) = imLookup edg edges - ndis <- gets vgNDI - let rndi = imLookup fr ndis - ndi <- vgInST $ readSTRef rndi - prodvs <- gets vgProdVisits - let nont = ndiNonterminal $ ndimOrig ndi - let prod = pdgProduction $ pdgmOrig $ ndimProds ndi !! p - let Just rprodv = Map.lookup (nont, prod, VGEdge edg) prodvs - vgInST $ modifySTRef rprodv (++ [st]) - --- | Get the state of a child in a certain production -getChildState :: VGProd -> Identifier -> VG s VGNode -getChildState (VGProd (VGEdge edg,p)) ide = do - childvs <- gets vgChildVisits - let rchildv = imLookup edg childvs - childv <- vgInST $ readSTRef rchildv - case Map.lookup (ide,p) childv of - Just (n:_) -> return n - _ -> do - -- Look for previous edge - edges <- gets vgEdges - let (VGNode from,_) = imLookup edg edges - incoming <- gets vgIncoming - case IntMap.lookup from incoming of - Just (Just iedg) -> getChildState (VGProd (iedg,p)) ide - Just Nothing -> do - -- Lookup initial state - ndis <- gets vgNDI - let rndi = imLookup from ndis - ndi <- vgInST $ readSTRef rndi - let Just nt = lookup ide $ pdgChildMap $ pdgmOrig $ (ndimProds ndi) !! p - vgFindInitial nt - Nothing -> error "getChildState" - --- | Repeat action untill mzero is encountered -repeatM :: VG s () -> VG s () -repeatM m = catchError (m >> repeatM m) (const $ return ()) - ------------------------------------------------------------- ---- Internal functions --- ------------------------------------------------------------- --- | Execute a ST action inside the VG monad -vgInST :: ST s a -> VG s a -vgInST = lift . lift - -vgEmptyState :: VGState s -vgEmptyState = VGState { vgNodeNum = 0 - , vgEdgeNum = 0 - , vgOutgoing = IntMap.empty - , vgIncoming = IntMap.empty - , vgNDI = IntMap.empty - , vgInhSynNode = Map.empty - , vgNodeInhSyn = IntMap.empty - , vgInitial = Map.empty - , vgEdges = IntMap.empty - , vgEdgesR = Map.empty - , vgInherited = IntMap.empty - , vgSynthesized = IntMap.empty - , vgPending = IntSet.empty - , vgChildVisits = IntMap.empty - , vgFinalVertices = IntMap.empty - , vgProdVisits = Map.empty - } --- | Create a new node -vgCreateNode :: STRef s (NontDependencyInformationM s) -> Set Identifier -> Set Identifier -> VG s VGNode -vgCreateNode rndi inh syn = do - num <- gets vgNodeNum - outgoing <- gets vgOutgoing - inhsyn <- gets vgInhSynNode - ninhsyn <- gets vgNodeInhSyn - ndi <- gets vgNDI - finalv <- gets vgFinalVertices - rout <- vgInST $ newSTRef Set.empty - rfinalv <- vgInST $ newSTRef Set.empty - nndi <- vgInST $ readSTRef rndi - modify $ \st -> st { vgNodeNum = num + 1 - , vgOutgoing = IntMap.insert num rout outgoing - , vgInhSynNode = Map.insert (ndiNonterminal $ ndimOrig nndi,inh,syn) (VGNode num) inhsyn - , vgNodeInhSyn = IntMap.insert num (inh,syn) ninhsyn - , vgNDI = IntMap.insert num rndi ndi - , vgFinalVertices = IntMap.insert num rfinalv finalv } - return $ VGNode num - --- | Create a new pending edge -vgCreatePendingEdge :: VGNode -> VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge -vgCreatePendingEdge vgn1@(VGNode n1) vgn2 inh syn = do - num <- gets vgEdgeNum - edges <- gets vgEdges - edgesr <- gets vgEdgesR - inhs <- gets vgInherited - syns <- gets vgSynthesized - outgoing <- gets vgOutgoing - pend <- gets vgPending - childv <- gets vgChildVisits - rchildv <- vgInST $ newSTRef Map.empty - let outr = imLookup n1 outgoing - let ret = VGEdge num - vgInST $ modifySTRef outr (Set.insert ret) - modify $ \st -> st { vgEdgeNum = num + 1 - , vgEdges = IntMap.insert num (vgn1,vgn2) edges - , vgEdgesR = Map.insert (vgn1,vgn2) ret edgesr - , vgPending = IntSet.insert num pend - , vgInherited = IntMap.insert num inh inhs - , vgSynthesized = IntMap.insert num syn syns - , vgChildVisits = IntMap.insert num rchildv childv } - -- Add prod visits (for constructing an execution plan) - ndis <- gets vgNDI - let rndi = imLookup n1 ndis - ndi <- vgInST $ readSTRef rndi - prodv <- gets vgProdVisits - refs <- forM (ndimProds ndi) $ \prod -> do - rprod <- vgInST $ newSTRef [] - return ((ndiNonterminal $ ndimOrig ndi, pdgProduction $ pdgmOrig prod, ret),rprod) - modify $ \st -> st { vgProdVisits = Map.union (Map.fromList refs) prodv } - return $ ret - --- | Check whether a vertex is marked final on this node in this production -vgDepGraphVertexFinal :: VGNode -> Int -> Vertex -> VG s Bool -vgDepGraphVertexFinal (VGNode n) p v = do - finalv <- gets vgFinalVertices - let rfinalv = imLookup n finalv - curset <- vgInST $ readSTRef rfinalv - if Set.member (v,p) curset - then return True - else do - incoming <- gets vgIncoming - case IntMap.lookup n incoming of - Just (Just (VGEdge edg)) -> do - edges <- gets vgEdges - let (fr,_) = imLookup edg edges - vgDepGraphVertexFinal fr p v - Just Nothing -> return False - Nothing -> error "This can never happen" - --- | Find the initial node for a nonterminal -vgFindInitial :: Identifier -> VG s VGNode -vgFindInitial nt = do - initial <- gets vgInitial - let Just r = Map.lookup nt initial - return r - --- | Always succeeding IntMap lookup -imLookup :: Int -> IntMap a -> a -imLookup k m = let Just r = IntMap.lookup k m in r - --- | Trace inside the vg monad -traceVG :: String -> VG s () -traceVG s = trace s (return ()) - ------------------------------------------------------------- ---- The kennedy warren algorithm --- ------------------------------------------------------------- -{- -runVG :: VG s a -> ST s a -insertInitialNode :: NontDependencyInformationM s -> VG s VGNode -createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge -selectPending :: VG s VGEdge -getInherited :: VGEdge -> VG s (Set Identifier) -getSynthesized :: VGEdge -> VG s (Set Identifier) -markFinal :: VGEdge -> VG s () -getProductions :: VGEdge -> VG s [VGProd] -onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a -isDepGraphVertexFinal :: VGProd -> Vertex -> VG s Bool -setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s () -getChildState :: VGProd -> Identifier -> VG s VGNode -addChildVisit :: VGProd -> Identifier -> VGEdge -> VG s VisitStep -addVisitStep :: VGProd -> VisitStep -> VG s () -repeatM :: VG s () -> VG s () --} - -kennedyWarrenVisitM :: Set NontermIdent -> [NontDependencyInformationM s] -> VG s [[VisitIdentifier]] -kennedyWarrenVisitM wr ndis = do - -- Create initial nodes and edges (edges only for wrapper nodes) - initvs <- forM ndis $ \ndi -> do - nd <- insertInitialNode ndi - let inh = Set.fromList $ ndiInh $ ndimOrig ndi - let syn = Set.fromList $ ndiSyn $ ndimOrig ndi - if (Set.member (ndiNonterminal $ ndimOrig $ ndi) wr) && (not (Set.null inh) || not (Set.null syn)) - then do - VGEdge initv <- createPending nd inh syn - return [initv] - else return [] - -- Handle all pending edges while there are any - repeatM $ do - pend <- selectPending - prods <- getProductions pend - inhs <- getInherited pend - syns <- getSynthesized pend - -- Handle each production for this edge - forM_ prods $ \prod -> do - -- Mark all inherited attributes as final - setDepGraphVerticesFinal prod (map createLhsInh . Set.toList $ inhs) - -- Find depth of all synthesized child visits - (vis,_) <- foldM (foldChildVisits prod) ([],0) (map createLhsSyn . Set.toList $ syns) - -- Mark them as final - setDepGraphVerticesFinal prod (map fst vis) - -- Change the inherited child visits - vis2 <- correctInhChilds prod vis - -- Add all synthesized attributes that are also ready but are not needed - extravis <- extraChildSyn prod vis2 - setDepGraphVerticesFinal prod (map fst extravis) - -- Group by visit number and do visit for every num - let gvis = groupSortBy (comparing snd) $ vis2 ++ extravis - forM_ gvis $ \vis3 -> do - -- Split child visits from rules - let (chattrs, rules) = partition isChildAttr $ map fst vis3 - -- Evaluate all rules - forM_ (reverse $ rules) $ \rule -> - case rule of - VRule r -> addVisitStep prod $ Sem r - VChild c -> addVisitStep prod $ ChildIntro c - _ -> return () - -- Now group by child, and do a visit for each child - let chs = groupSortBy (comparing getAttrChildName) $ chattrs - chvs <- forM chs $ \childvs -> do -- childs :: [Vertex] - let cinhs = map getAttrName $ filter isChildInh childvs - let csyns = map getAttrName $ filter isChildSyn childvs - let cname = getAttrChildName $ head childvs - -- Insert a new pending edge for this visit - curstate <- getChildState prod cname - target <- createPending curstate (Set.fromList cinhs) (Set.fromList csyns) - addChildVisit prod cname target - -- Add child visits as simultanuous step - when (not $ null chvs) $ - if (length chvs == 1) - then addVisitStep prod $ head chvs - else addVisitStep prod $ Sim chvs - - -- Mark this edge as final - markFinal pend - -- We are done - -- traceVG "Done." - return initvs - --- | groupBy that groups all equal (according to the function) elements instead of consequtive equal elements -groupSortBy :: (a -> a -> Ordering) -> [a] -> [[a]] -groupSortBy f = groupBy (\x y -> f x y == EQ) . sortBy f - -type ChildVisits = [(Vertex,Int)] - --- | Helper function for folding over child visits -foldChildVisits :: VGProd -> (ChildVisits, Int) -> Vertex -> VG s (ChildVisits, Int) -foldChildVisits prod (vis,i) v = do - (nvis,ni) <- findChildVisits prod v vis - return (nvis, ni `max` i) - --- | Recursively find all visits to childs -findChildVisits :: VGProd -> Vertex -> ChildVisits -> VG s (ChildVisits, Int) -findChildVisits prod v vis = do - case lookup v vis of - Just i -> return (vis,i) - Nothing -> do - final <- isDepGraphVertexFinal prod v - if final - then return (vis,0) - else do - succs <- onMarkedDepGraph (liftM Set.toList . flip graphSuccessors v . pdgmDepGraph) prod - (nvis,ni) <- foldM (foldChildVisits prod) (vis,0) succs - if isChildSyn v - then return ((v,ni + 1) : nvis, ni + 1) - else return ((v,ni) : nvis, ni) - --- | Correct inherited child visits after foldChildVisits -correctInhChilds :: VGProd -> ChildVisits -> VG s ChildVisits -correctInhChilds prod vis = - forM vis $ \(v,i) -> do - if isChildInh v - then do - preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod - let ni = foldl min 99999999 $ mapMaybe (`lookup` vis) preds - return (v,ni) - else if not $ isChildSyn v - then do - succs <- onMarkedDepGraph (liftM Set.toList . flip graphSuccessors v . pdgmDepGraph) prod - let ni = foldl max (-1) $ mapMaybe (`lookup` vis) succs - return (v,ni+1) - else return (v,i) - --- | Synthesized attributes that can also be evaluated -extraChildSyn :: VGProd -> ChildVisits -> VG s ChildVisits -extraChildSyn prod vis = do - allpreds <- forM vis $ \(v,_) -> do - if isChildInh v - then do - preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod - return $ Set.fromList $ filter isChildSyn preds - else return Set.empty - lextravis <- forM (Set.toList $ Set.unions allpreds) $ \v -> do - ready <- isReadyVertex prod vis v - return $ maybe Nothing (\i -> Just (v,i)) ready - return $ catMaybes lextravis - --- | Check if a vertex can be marked final in this step (and is not final yet) and return the visit num -isReadyVertex :: VGProd -> ChildVisits -> Vertex -> VG s (Maybe Int) -isReadyVertex prod vis v = do - final <- isDepGraphVertexFinal prod v - if v `elem` (map fst vis) || final - then return Nothing - else do - succ <- onMarkedDepGraph (flip graphSuccessors v . pdgmDepGraph) prod - rd <- mapM (\x -> do case lookup x vis of - Just i -> return $ Just i - Nothing -> do fin <- isDepGraphVertexFinal prod x - return $ if fin then Just 1 else Nothing) (Set.toList succ) - if all isJust rd - then return $ Just $ foldl1 max $ catMaybes rd - else return $ Nothing - --- | Check if this vertex is a synthesized attribute of a child -isChildSyn :: Vertex -> Bool -isChildSyn v = isChildAttr v && getAttrType v == Syn - --- | Check if this vertex is an inherited attribute of a child -isChildInh :: Vertex -> Bool -isChildInh v = isChildAttr v && getAttrType v == Inh - --- | Check if this vertex is an attribute of a child -isChildAttr :: Vertex -> Bool -isChildAttr v = isVertexAttr v && getAttrChildName v /= _LHS && getAttrType v /= Loc - --- | Create lhs.inh vertex -createLhsInh :: Identifier -> Vertex -createLhsInh = VAttr Inh _LHS - --- | Create lhs.inh vertex -createLhsSyn :: Identifier -> Vertex -createLhsSyn = VAttr Syn _LHS - ------------------------------------------------------------- ---- Construction of the execution plan --- ------------------------------------------------------------- -kennedyWarrenExecutionPlan :: Options -> [NontDependencyInformationM s] -> [[VisitIdentifier]] -> - Set NontermIdent -> TypeSyns -> Derivings -> VG s ExecutionPlan -kennedyWarrenExecutionPlan opts ndis initvs wr typesyns derivings = do - -- Loop over all nonterminals - nonts <- forM (zip ndis initvs) $ \(ndi, initv) -> do - -- Loop over all productions of this nonterminal - prods <- forM (ndimProds ndi) $ \prod -> do - -- Construct the visits for this production - let inont = ndiNonterminal $ ndimOrig ndi - let iprod = pdgProduction $ pdgmOrig prod - prodvs <- gets vgProdVisits - let thisvisits = filter (\((int,ipr,_),_) -> int == inont && ipr == iprod) $ Map.toList prodvs - visits <- forM thisvisits $ \((_,_,vgedg@(VGEdge edg)),rprodvs) -> do - edges <- gets vgEdges - let (VGNode fr, VGNode to) = imLookup edg edges - steps <- vgInST $ readSTRef rprodvs - inh <- getInherited vgedg - syn <- getSynthesized vgedg - let kind | monadic opts = VisitMonadic - | otherwise = VisitPure True - return $ Visit edg fr to inh syn steps kind - -- Return execution plan for this production - return $ EProduction (pdgProduction $ pdgmOrig prod) - (pdgParams $ pdgmOrig prod) - (pdgConstraints $ pdgmOrig prod) - (pdgRules $ pdgmOrig prod) - (pdgChilds $ pdgmOrig prod) - visits - -- Find initial state for this nonterminal - VGNode init <- vgFindInitial $ ndiNonterminal $ ndimOrig ndi - -- Construct an environment that specifies the next visit of the states that have exactly one - nextMap <- mkNextMap init - prevMap <- mkPrevMap init - -- Return execution plan for this nonterminal - return $ ENonterminal (ndiNonterminal $ ndimOrig ndi) - (ndiParams $ ndimOrig ndi) - (ndiClassCtxs $ ndimOrig ndi) - init - initv - nextMap - prevMap - prods - (ndiRecursive $ ndimOrig ndi) - (ndiHoInfo $ ndimOrig ndi) - - -- Return complete execution plan - return $ ExecutionPlan nonts typesyns wr derivings - ------------------------------------------------------------- ---- Construction of the single-exit states map --- ------------------------------------------------------------- - --- depth-first traversal over the graph that starts at 'init' and maintains a state 'a' --- the function 'f' can inspect the prev/next edges per state -exploreGraph :: (VGNode -> Set VGEdge -> Set VGEdge -> a -> VG s a) -> VGNode -> a -> VG s a -exploreGraph f (VGNode init) a0 = do - exploredRef <- vgInST $ newSTRef IntSet.empty - pendingRef <- vgInST $ newSTRef [init] - resRef <- vgInST $ newSTRef a0 - outgoingMap <- gets vgOutgoing - edgesInfo <- gets vgEdges - let explore = do - pending <- vgInST $ readSTRef pendingRef - case pending of - [] -> return () - (p:ps) -> do - vgInST $ writeSTRef pendingRef ps - explored <- vgInST $ readSTRef exploredRef - if IntSet.member p explored - then return () - else do - vgInST $ writeSTRef exploredRef (IntSet.insert p explored) - case IntMap.lookup p outgoingMap of - Nothing -> return () - Just outRef -> case IntMap.lookup p outgoingMap of - Nothing -> return () - Just inRef -> do - outSet <- vgInST $ readSTRef outRef - inSet <- vgInST $ readSTRef inRef - sol0 <- vgInST $ readSTRef resRef - sol1 <- f (VGNode p) inSet outSet sol0 - vgInST $ writeSTRef resRef sol1 - forM_ (Set.elems outSet) $ \(VGEdge edge) -> - case IntMap.lookup edge edgesInfo of - Nothing -> return () - Just (_,VGNode to) -> vgInST $ modifySTRef pendingRef (to :) - explore - explore - vgInST $ readSTRef resRef - -mkNextMap :: Int -> VG s (Map Int StateCtx) -mkNextMap start = exploreGraph f (VGNode start) Map.empty where - f (VGNode nd) _ edges = updateCountMap nd edges - -mkPrevMap :: Int -> VG s (Map Int StateCtx) -mkPrevMap start = exploreGraph f (VGNode start) Map.empty where - f (VGNode nd) edges _ = updateCountMap nd edges - -updateCountMap :: Int -> Set VGEdge -> Map Int StateCtx -> VG s (Map Int StateCtx) -updateCountMap nd edges mp = return $ Map.insert nd v mp where - s = Set.size edges - v | s == 0 = NoneVis - | s == 1 = let [VGEdge v'] = Set.elems edges - in OneVis v' - | otherwise = ManyVis +module KennedyWarren where + +import Prelude hiding (init, succ) +import CommonTypes +import Pretty +import Knuth1 +import ExecutionPlan +import Debug.Trace +import Control.Monad.ST +import Control.Monad.State +import Control.Monad.Error +import Data.STRef +import Data.Maybe +import Data.List (intersperse, groupBy, partition, sortBy) +import Data.Ord +import qualified ErrorMessages as Err +import PrintErrorMessages () + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + +-- lazy version (does not return errors) +-- FIXME: construct map from nonterminal to intial visit (or state?) and use it in the generation of invokes +kennedyWarrenLazy :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> ExecutionPlan +kennedyWarrenLazy _ wr ndis typesyns derivings = plan where + plan = ExecutionPlan nonts typesyns wr derivings + nonts = zipWith mkNont ndis nontIds + nontIds = enumFromThen 1 4 + initvMap = Map.fromList $ zipWith (\ndi initv -> (ndiNonterminal ndi, initv)) ndis nontIds + + mkNont ndi initv = nont where + nont = ENonterminal + (ndiNonterminal ndi) + (ndiParams ndi) + (ndiClassCtxs ndi) + initst + [initv] + nextMap + prevMap + prods + (ndiRecursive ndi) + (ndiHoInfo ndi) + initst = initv + 1 + finals = initv + 2 + nextMap = Map.fromList [(initst, OneVis initv), (finals, NoneVis)] + prevMap = Map.fromList [(initst, NoneVis), (finals, OneVis initv)] + prods = map mkProd (ndiProds ndi) + + mkProd pdi = prod where + prod = EProduction + (pdgProduction pdi) + (pdgParams pdi) + (pdgConstraints pdi) + (pdgRules pdi) + (pdgChilds pdi) + visits + visits = [vis] + vis = Visit initv initst finals inh syn steps kind + inh = Set.fromList $ ndiInh ndi + syn = Set.fromList $ ndiSyn ndi + kind = VisitPure False + steps = childSteps ++ invokeSteps ++ ruleSteps + + childSteps = [ ChildIntro nm | EChild nm _ _ _ _ _ <- pdgChilds pdi ] + invokeSteps = [ ChildVisit nm nt v + | EChild nm tp _ _ _ _ <- pdgChilds pdi + , let nt = extractNonterminal tp + v = Map.findWithDefault (error "child not in initv-map") nt initvMap + ] + ruleSteps = [ Sem nm | (ERule nm _ _ _ _ _ _ _) <- pdgRules pdi ] + + +-- ordered version (may return errors) +kennedyWarrenOrder :: Options -> Set NontermIdent -> [NontDependencyInformation] -> TypeSyns -> Derivings -> Either Err.Error (ExecutionPlan, PP_Doc, PP_Doc) +kennedyWarrenOrder opts wr ndis typesyns derivings = runST $ runErrorT $ do + indi <- lift $ mapM mkNontDependencyInformationM ndis + lift $ knuth1 indi + -- Check all graphs for cyclicity, transitive closure and consistency + -- traceST $ "Checking graphs..." + forM_ indi $ \ndi -> do + let nont = ndiNonterminal . ndimOrig $ ndi + let g = ndgmDepGraph . ndimDepGraph $ ndi + -- Topological sort + --tsedg <- graphTopSort g + -- Cyclicity check + ntCycVerts <- lift $ graphCyclicVerticesExt g + when (not $ null ntCycVerts) $ do + throwError $ Err.Cyclic nont Nothing (map show ntCycVerts) +-- let msg = "Nonterminal graph " ++ show nont ++ " is cylic!" +-- fail msg + -- Transtive closure check + trc <- lift $ graphIsTRC g + when (not trc) $ do + let msg = "Nonterminal graph " ++ show nont ++ " is not transitively closed!" + fail msg + -- Consistency check + cons <- lift $ graphCheckConsistency g + when (not cons) $ do + let msg = "Nonterminal graph " ++ show nont ++ " is not consistent!" + fail msg + + -- Loop trough all productions + forM_ (ndimProds ndi) $ \prod -> do + let pr = pdgProduction $ pdgmOrig prod + let g' = pdgmDepGraph $ prod + -- Topsort + --addTopSortEdges tsedg prod + -- Check for cyclicity + pdCycVerts <- lift $ graphCyclicVerticesExt g' + when (not $ null pdCycVerts) $ do + throwError $ Err.Cyclic nont (Just pr) (map show pdCycVerts) + -- let msg = "Production graph " ++ show pr ++ " of nonterminal " + -- ++ show nont ++ " is cylic!" + -- fail msg + -- Transtive closure check + trc' <- lift $ graphIsTRC g' + when (not trc') $ do + lift $ traceST $ "Production graph " ++ show pr ++ " of nonterminal " + ++ show nont ++ " is not transitively closed!" + fail "Production graph is not transitively closed." + -- Check consistency + consistent <- lift $ graphCheckConsistency g' + when (not consistent) $ do + let msg = "Production graph " ++ show pr ++ " of nonterminal " + ++ show nont ++ " is not consistent!" + fail msg + -- reachable when everything is ok + lift $ do + -- Create non-transitive closed graph for efficiency + indi' <- undoTransitiveClosure indi + -- Graphviz output of dependency graphs + gvs <- mapM toGVNontDependencyInfo indi' + -- Doing kennedywarren + (ret, visitg) <- runVG $ do + -- traceVG $ "Running kennedy-warren..." + initvs <- kennedyWarrenVisitM wr indi' + -- Print some debug info + nodes <- gets vgNodeNum + edges <- gets vgEdgeNum + when (not $ beQuiet opts) $ do + traceVG $ "Number of nodes = " ++ show nodes + traceVG $ "Number of edges = " ++ show edges + -- Generate execution plan + ex <- kennedyWarrenExecutionPlan opts indi' initvs wr typesyns derivings + -- Get visit graph + visitg <- toGVVisitGraph + return (ex,visitg) + -- Return the result + return (ret, vlist gvs, visitg) + +------------------------------------------------------------------------------- +-- Debugging functionality +------------------------------------------------------------------------------- + +-- | Pretty print a vertex in GraphViz format +toGVVertex :: Bool -> Vertex -> ST s PP_Doc +toGVVertex l (VAttr t a b) = return $ (text $ "attr_" ++ show t ++ "_" ++ show a ++ "_" ++ show b) >#< if l + then text ("[shape=box,label=\"" ++ show t ++ " @" ++ show a ++ "." ++ show b ++ "\"]") else empty +toGVVertex l (VChild c) = return $ (text $ "child_" ++ show c) >#< if l + then text ("[shape=ellipse,label=\"Child " ++ show c ++ "\"]") else empty +toGVVertex l (VRule r) = return $ (text $ "rule_" ++ show r) >#< if l + then text ("[shape=diamond,label=\"" ++ show r ++ "\"]") else empty + +-- | Pretty print an edge in GraphViz format +toGVEdge :: Edge -> ST s PP_Doc +toGVEdge (v1, v2) = do r1 <- toGVVertex False v1 + r2 <- toGVVertex False v2 + return $ r1 >|< text "->" >#< r2 + +-- | Pretty print a NontDependencyInformation in GraphViz format +toGVNontDependencyInfo :: NontDependencyInformationM s -> ST s PP_Doc +toGVNontDependencyInfo ndi = do dg <- return $ ndgmDepGraph . ndimDepGraph $ ndi + verts <- graphVertices dg + edges <- graphEdges dg + vtexts <- mapM (toGVVertex True) verts + etexts <- mapM toGVEdge edges + ptexts <- mapM toGVProdDependencyGraph (ndimProds ndi) + return $ (text ("digraph ndg_" ++ show (ndiNonterminal $ ndimOrig ndi) ++ " {") + >-< + vlist vtexts + >-< + vlist etexts + >-< + text "}" + >-< + text "" -- empty line + >-< + vlist ptexts) + +-- | Pretty print a ProdDependencyGraph in GraphViz format +toGVProdDependencyGraph :: ProdDependencyGraphM s -> ST s PP_Doc +toGVProdDependencyGraph pdg = do dg <- return $ pdgmDepGraph pdg + verts <- graphVertices dg + edges <- graphEdges dg + vtexts <- mapM (toGVVertex True) verts + etexts <- mapM toGVEdge edges + return $ (text ("digraph pdg_" ++ show (pdgProduction $ pdgmOrig pdg) ++ " {") + >-< + (vlist vtexts) + >-< + (vlist etexts) + >-< + text ("info [shape=box,label=\"" ++ show (pdgChildMap $ pdgmOrig pdg) ++ "\"];") + >-< + text "}" + >-< + text "") + +toGVVisitGraph :: VG s PP_Doc +toGVVisitGraph = do + ndis <- gets vgNDI + noded <- forM (IntMap.toList ndis) $ \(n,rndi) -> do + ndi <- vgInST $ readSTRef rndi + return $ "node_" >|< n >#< "[label=\"" >|< ndiNonterminal (ndimOrig ndi) >|< "_" >|< n >|< "\"];" + edges <- gets vgEdges + edged <- forM (IntMap.toList edges) $ \(edg,(VGNode from,VGNode to)) -> do + inh <- getInherited (VGEdge edg) + syn <- getSynthesized (VGEdge edg) + return $ "node_" >|< from >#< "-> node_" >|< to >#< "[label=\"visit v" >|< edg + >|< "\\ninh:" >#< (concat $ intersperse ", " $ map show $ Set.toList inh) >|< "\\nsyn: " >|< (concat $ intersperse ", " $ map show $ Set.toList syn) >|< "\"];" + return $ "digraph visitgraph { " >-< vlist noded >-< vlist edged >-< "}" + +------------------------------------------------------------------------------- +-- Kennedy-Warren in monadic style +------------------------------------------------------------------------------- +{- +runVG :: VG s a -> ST s a +insertInitialNode :: NontDependencyInformationM s -> VG s VGNode +createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge +selectPending :: VG s VGEdge +getInherited :: VGEdge -> VG s (Set Identifier) +getSynthesized :: VGEdge -> VG s (Set Identifier) +markFinal :: VGEdge -> VG s () +getProductions :: VGEdge -> VG s [VGProd] +onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a +isDepGraphVertexFinal :: VGProd -> Vertex -> VG s Bool +setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s () +getChildState :: VGProd -> Identifier -> VG s VGNode +addChildVisit :: VGProd -> Identifier -> VGEdge -> VG s VisitStep +addVisitStep :: VGProd -> VisitStep -> VG s () +repeatM :: VG s () -> VG s () +-} + +newtype VGNode = VGNode Int deriving (Show,Eq,Ord) +newtype VGEdge = VGEdge Int deriving (Show,Eq,Ord) +newtype VGProd = VGProd (VGEdge,Int) deriving (Show,Eq,Ord) + +data VGState s = VGState { vgNodeNum :: Int + , vgEdgeNum :: Int + -- Node maps + , vgOutgoing :: IntMap (STRef s (Set VGEdge)) + , vgIncoming :: IntMap (Maybe VGEdge) + , vgNDI :: IntMap (STRef s (NontDependencyInformationM s)) + , vgInhSynNode :: Map (Identifier, Set Identifier, Set Identifier) VGNode + , vgNodeInhSyn :: IntMap (Set Identifier, Set Identifier) + , vgInitial :: Map Identifier VGNode + -- Edge maps + , vgEdges :: IntMap (VGNode, VGNode) + , vgEdgesR :: Map (VGNode,VGNode) VGEdge + , vgInherited :: IntMap (Set Identifier) + , vgSynthesized :: IntMap (Set Identifier) + , vgPending :: IntSet + , vgChildVisits :: IntMap (STRef s (Map (Identifier,Int) [VGNode])) + -- Final vertices in production graphs + , vgFinalVertices :: IntMap (STRef s (Set (Vertex,Int))) + -- Construction of execution plan (Nonterminal,Production,Visit) + , vgProdVisits :: Map (Identifier,Identifier,VGEdge) (STRef s [VisitStep]) + } + +type VG s a = ErrorT String (StateT (VGState s) (ST s)) a + +------------------------------------------------------------ +--- Public functions --- +------------------------------------------------------------ +-- | Run the VG monad in the ST monad +runVG :: VG s a -> ST s a +runVG vg = do result <- runStateT (runErrorT vg) vgEmptyState + let (Right a,_) = result + return a + +-- | Insert an initial node for this nonterminal into the visit graph +insertInitialNode :: NontDependencyInformationM s -> VG s VGNode +insertInitialNode ndi = do + rndi <- vgInST $ newSTRef ndi + (VGNode node) <- vgCreateNode rndi Set.empty Set.empty + initial <- gets vgInitial + incoming <- gets vgIncoming + modify $ \st -> st { vgInitial = Map.insert (ndiNonterminal $ ndimOrig ndi) (VGNode node) initial + , vgIncoming = IntMap.insert node Nothing incoming } + return (VGNode node) + +-- | Create a pending edge from this node with a set of inherited and synthesized attributes +createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge +createPending vgn@(VGNode n) inh syn = do + -- Check if target node already exists + ninhsyn <- gets vgNodeInhSyn + let (pinh,psyn) = imLookup n ninhsyn + let ninh = Set.union pinh inh + let nsyn = Set.union psyn syn + mndi <- gets vgNDI + let rndi = imLookup n mndi + ndi <- vgInST $ readSTRef rndi + inhsynn <- gets vgInhSynNode + case Map.lookup (ndiNonterminal $ ndimOrig ndi, ninh, nsyn) inhsynn of + Just tn -> do + when (tn == vgn) $ do traceVG $ "Source and target nodes are the same!" + traceVG $ "Maybe there is a wrapper with no inherited or synthesized attributes." + traceVG $ "Inh: " ++ show inh + traceVG $ "Syn: " ++ show syn + traceVG $ "PInh: " ++ show pinh + traceVG $ "PSyn: " ++ show psyn + -- tn is target node, now check if edge exists and create if not + edgesr <- gets vgEdgesR + case Map.lookup (vgn,tn) edgesr of + Just e -> return e + Nothing -> vgCreatePendingEdge vgn tn inh syn + Nothing -> do + -- target node does not exist, create it and then create the new edge + tn <- vgCreateNode rndi ninh nsyn + vgCreatePendingEdge vgn tn inh syn + +-- | Return an arbitrary pending edge of which the from node is ready +selectPending :: VG s VGEdge +selectPending = do + pending <- gets vgPending + incoming <- gets vgIncoming + edges <- gets vgEdges + let readyPend = filter (\p -> let (VGNode fr,_) = imLookup p edges + in isJust $ IntMap.lookup fr incoming) $ IntSet.toList pending + guard $ not $ null readyPend + return $ VGEdge $ head $ readyPend + +-- | Get the inherited attributes of an edge +getInherited :: VGEdge -> VG s (Set Identifier) +getInherited (VGEdge edg) = do + inhs <- gets vgInherited + return $ imLookup edg inhs + +-- | Get the synthesized attributes of an edge +getSynthesized :: VGEdge -> VG s (Set Identifier) +getSynthesized (VGEdge edg) = do + syns <- gets vgSynthesized + return $ imLookup edg syns + +-- | Mark an edge as final +markFinal :: VGEdge -> VG s () +markFinal vgedg@(VGEdge edg) = do + incoming <- gets vgIncoming + edges <- gets vgEdges + pending <- gets vgPending + let (_,VGNode to) = imLookup edg edges + modify $ \st -> st { vgIncoming = IntMap.insert to (Just vgedg) incoming + , vgPending = IntSet.delete edg pending } + +-- | Get all productions for an edge +getProductions :: VGEdge -> VG s [VGProd] +getProductions vedg@(VGEdge edg) = do + edges <- gets vgEdges + let (VGNode fr,_) = imLookup edg edges + ndis <- gets vgNDI + let rndi = imLookup fr ndis + ndi <- vgInST $ readSTRef rndi + return $ map (\x -> VGProd (vedg,x)) [0..(length $ ndimProds ndi)-1] + +-- | Execute a function on the dependency graph for this production +onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a +onMarkedDepGraph f (VGProd (VGEdge edg, n)) = do + edges <- gets vgEdges + let (VGNode fr,_) = imLookup edg edges + ndis <- gets vgNDI + let rndi = imLookup fr ndis + ndi <- vgInST $ readSTRef rndi + vgInST $ f $ (ndimProds ndi) !! n -- not efficient, but lists are usually short + +-- | Check whether this vertex has been marked as final +isDepGraphVertexFinal :: VGProd -> Vertex -> VG s Bool +isDepGraphVertexFinal (VGProd (VGEdge edg, p)) v = do + edges <- gets vgEdges + let (from,_) = imLookup edg edges + vgDepGraphVertexFinal from p v + +-- | Mark these vertices final in this production +setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s () +setDepGraphVerticesFinal (VGProd (VGEdge edg, p)) vs = do + edges <- gets vgEdges + let (_,VGNode to) = imLookup edg edges + finalv <- gets vgFinalVertices + let rfinalv = imLookup to finalv + vgInST $ modifySTRef rfinalv $ Set.union (Set.fromList $ map (\v -> (v,p)) vs) + +-- | Add a child visit to this production and return the step for the execution plan +addChildVisit :: VGProd -> Identifier -> VGEdge -> VG s VisitStep +addChildVisit (VGProd (VGEdge edg, p)) ide (VGEdge vs) = do + edges <- gets vgEdges + let (VGNode from,vgto) = imLookup vs edges -- from must be equal to the current state + childvs <- gets vgChildVisits + let rchildv = imLookup edg childvs + vgInST $ modifySTRef rchildv $ MapStrict.insertWith (++) (ide,p) [vgto] + ndis <- gets vgNDI + let rndi = imLookup from ndis + ndi <- vgInST $ readSTRef rndi + let nt = ndiNonterminal $ ndimOrig ndi + return $ ChildVisit ide nt vs + +-- | Add a step to the execution plan of this visit +addVisitStep :: VGProd -> VisitStep -> VG s () +addVisitStep (VGProd (VGEdge edg, p)) st = do + edges <- gets vgEdges + let (VGNode fr,_) = imLookup edg edges + ndis <- gets vgNDI + let rndi = imLookup fr ndis + ndi <- vgInST $ readSTRef rndi + prodvs <- gets vgProdVisits + let nont = ndiNonterminal $ ndimOrig ndi + let prod = pdgProduction $ pdgmOrig $ ndimProds ndi !! p + let Just rprodv = Map.lookup (nont, prod, VGEdge edg) prodvs + vgInST $ modifySTRef rprodv (++ [st]) + +-- | Get the state of a child in a certain production +getChildState :: VGProd -> Identifier -> VG s VGNode +getChildState (VGProd (VGEdge edg,p)) ide = do + childvs <- gets vgChildVisits + let rchildv = imLookup edg childvs + childv <- vgInST $ readSTRef rchildv + case Map.lookup (ide,p) childv of + Just (n:_) -> return n + _ -> do + -- Look for previous edge + edges <- gets vgEdges + let (VGNode from,_) = imLookup edg edges + incoming <- gets vgIncoming + case IntMap.lookup from incoming of + Just (Just iedg) -> getChildState (VGProd (iedg,p)) ide + Just Nothing -> do + -- Lookup initial state + ndis <- gets vgNDI + let rndi = imLookup from ndis + ndi <- vgInST $ readSTRef rndi + let Just nt = lookup ide $ pdgChildMap $ pdgmOrig $ (ndimProds ndi) !! p + vgFindInitial nt + Nothing -> error "getChildState" + +-- | Repeat action untill mzero is encountered +repeatM :: VG s () -> VG s () +repeatM m = catchError (m >> repeatM m) (const $ return ()) + +------------------------------------------------------------ +--- Internal functions --- +------------------------------------------------------------ +-- | Execute a ST action inside the VG monad +vgInST :: ST s a -> VG s a +vgInST = lift . lift + +vgEmptyState :: VGState s +vgEmptyState = VGState { vgNodeNum = 0 + , vgEdgeNum = 0 + , vgOutgoing = IntMap.empty + , vgIncoming = IntMap.empty + , vgNDI = IntMap.empty + , vgInhSynNode = Map.empty + , vgNodeInhSyn = IntMap.empty + , vgInitial = Map.empty + , vgEdges = IntMap.empty + , vgEdgesR = Map.empty + , vgInherited = IntMap.empty + , vgSynthesized = IntMap.empty + , vgPending = IntSet.empty + , vgChildVisits = IntMap.empty + , vgFinalVertices = IntMap.empty + , vgProdVisits = Map.empty + } +-- | Create a new node +vgCreateNode :: STRef s (NontDependencyInformationM s) -> Set Identifier -> Set Identifier -> VG s VGNode +vgCreateNode rndi inh syn = do + num <- gets vgNodeNum + outgoing <- gets vgOutgoing + inhsyn <- gets vgInhSynNode + ninhsyn <- gets vgNodeInhSyn + ndi <- gets vgNDI + finalv <- gets vgFinalVertices + rout <- vgInST $ newSTRef Set.empty + rfinalv <- vgInST $ newSTRef Set.empty + nndi <- vgInST $ readSTRef rndi + modify $ \st -> st { vgNodeNum = num + 1 + , vgOutgoing = IntMap.insert num rout outgoing + , vgInhSynNode = Map.insert (ndiNonterminal $ ndimOrig nndi,inh,syn) (VGNode num) inhsyn + , vgNodeInhSyn = IntMap.insert num (inh,syn) ninhsyn + , vgNDI = IntMap.insert num rndi ndi + , vgFinalVertices = IntMap.insert num rfinalv finalv } + return $ VGNode num + +-- | Create a new pending edge +vgCreatePendingEdge :: VGNode -> VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge +vgCreatePendingEdge vgn1@(VGNode n1) vgn2 inh syn = do + num <- gets vgEdgeNum + edges <- gets vgEdges + edgesr <- gets vgEdgesR + inhs <- gets vgInherited + syns <- gets vgSynthesized + outgoing <- gets vgOutgoing + pend <- gets vgPending + childv <- gets vgChildVisits + rchildv <- vgInST $ newSTRef Map.empty + let outr = imLookup n1 outgoing + let ret = VGEdge num + vgInST $ modifySTRef outr (Set.insert ret) + modify $ \st -> st { vgEdgeNum = num + 1 + , vgEdges = IntMap.insert num (vgn1,vgn2) edges + , vgEdgesR = Map.insert (vgn1,vgn2) ret edgesr + , vgPending = IntSet.insert num pend + , vgInherited = IntMap.insert num inh inhs + , vgSynthesized = IntMap.insert num syn syns + , vgChildVisits = IntMap.insert num rchildv childv } + -- Add prod visits (for constructing an execution plan) + ndis <- gets vgNDI + let rndi = imLookup n1 ndis + ndi <- vgInST $ readSTRef rndi + prodv <- gets vgProdVisits + refs <- forM (ndimProds ndi) $ \prod -> do + rprod <- vgInST $ newSTRef [] + return ((ndiNonterminal $ ndimOrig ndi, pdgProduction $ pdgmOrig prod, ret),rprod) + modify $ \st -> st { vgProdVisits = Map.union (Map.fromList refs) prodv } + return $ ret + +-- | Check whether a vertex is marked final on this node in this production +vgDepGraphVertexFinal :: VGNode -> Int -> Vertex -> VG s Bool +vgDepGraphVertexFinal (VGNode n) p v = do + finalv <- gets vgFinalVertices + let rfinalv = imLookup n finalv + curset <- vgInST $ readSTRef rfinalv + if Set.member (v,p) curset + then return True + else do + incoming <- gets vgIncoming + case IntMap.lookup n incoming of + Just (Just (VGEdge edg)) -> do + edges <- gets vgEdges + let (fr,_) = imLookup edg edges + vgDepGraphVertexFinal fr p v + Just Nothing -> return False + Nothing -> error "This can never happen" + +-- | Find the initial node for a nonterminal +vgFindInitial :: Identifier -> VG s VGNode +vgFindInitial nt = do + initial <- gets vgInitial + let Just r = Map.lookup nt initial + return r + +-- | Always succeeding IntMap lookup +imLookup :: Int -> IntMap a -> a +imLookup k m = let Just r = IntMap.lookup k m in r + +-- | Trace inside the vg monad +traceVG :: String -> VG s () +traceVG s = trace s (return ()) + +------------------------------------------------------------ +--- The kennedy warren algorithm --- +------------------------------------------------------------ +{- +runVG :: VG s a -> ST s a +insertInitialNode :: NontDependencyInformationM s -> VG s VGNode +createPending :: VGNode -> Set Identifier -> Set Identifier -> VG s VGEdge +selectPending :: VG s VGEdge +getInherited :: VGEdge -> VG s (Set Identifier) +getSynthesized :: VGEdge -> VG s (Set Identifier) +markFinal :: VGEdge -> VG s () +getProductions :: VGEdge -> VG s [VGProd] +onMarkedDepGraph :: (ProdDependencyGraphM s -> ST s a) -> VGProd -> VG s a +isDepGraphVertexFinal :: VGProd -> Vertex -> VG s Bool +setDepGraphVerticesFinal :: VGProd -> [Vertex] -> VG s () +getChildState :: VGProd -> Identifier -> VG s VGNode +addChildVisit :: VGProd -> Identifier -> VGEdge -> VG s VisitStep +addVisitStep :: VGProd -> VisitStep -> VG s () +repeatM :: VG s () -> VG s () +-} + +kennedyWarrenVisitM :: Set NontermIdent -> [NontDependencyInformationM s] -> VG s [[VisitIdentifier]] +kennedyWarrenVisitM wr ndis = do + -- Create initial nodes and edges (edges only for wrapper nodes) + initvs <- forM ndis $ \ndi -> do + nd <- insertInitialNode ndi + let inh = Set.fromList $ ndiInh $ ndimOrig ndi + let syn = Set.fromList $ ndiSyn $ ndimOrig ndi + if (Set.member (ndiNonterminal $ ndimOrig $ ndi) wr) && (not (Set.null inh) || not (Set.null syn)) + then do + VGEdge initv <- createPending nd inh syn + return [initv] + else return [] + -- Handle all pending edges while there are any + repeatM $ do + pend <- selectPending + prods <- getProductions pend + inhs <- getInherited pend + syns <- getSynthesized pend + -- Handle each production for this edge + forM_ prods $ \prod -> do + -- Mark all inherited attributes as final + setDepGraphVerticesFinal prod (map createLhsInh . Set.toList $ inhs) + -- Find depth of all synthesized child visits + (vis,_) <- foldM (foldChildVisits prod) ([],0) (map createLhsSyn . Set.toList $ syns) + -- Mark them as final + setDepGraphVerticesFinal prod (map fst vis) + -- Change the inherited child visits + vis2 <- correctInhChilds prod vis + -- Add all synthesized attributes that are also ready but are not needed + extravis <- extraChildSyn prod vis2 + setDepGraphVerticesFinal prod (map fst extravis) + -- Group by visit number and do visit for every num + let gvis = groupSortBy (comparing snd) $ vis2 ++ extravis + forM_ gvis $ \vis3 -> do + -- Split child visits from rules + let (chattrs, rules) = partition isChildAttr $ map fst vis3 + -- Evaluate all rules + forM_ (reverse $ rules) $ \rule -> + case rule of + VRule r -> addVisitStep prod $ Sem r + VChild c -> addVisitStep prod $ ChildIntro c + _ -> return () + -- Now group by child, and do a visit for each child + let chs = groupSortBy (comparing getAttrChildName) $ chattrs + chvs <- forM chs $ \childvs -> do -- childs :: [Vertex] + let cinhs = map getAttrName $ filter isChildInh childvs + let csyns = map getAttrName $ filter isChildSyn childvs + let cname = getAttrChildName $ head childvs + -- Insert a new pending edge for this visit + curstate <- getChildState prod cname + target <- createPending curstate (Set.fromList cinhs) (Set.fromList csyns) + addChildVisit prod cname target + -- Add child visits as simultanuous step + when (not $ null chvs) $ + if (length chvs == 1) + then addVisitStep prod $ head chvs + else addVisitStep prod $ Sim chvs + + -- Mark this edge as final + markFinal pend + -- We are done + -- traceVG "Done." + return initvs + +-- | groupBy that groups all equal (according to the function) elements instead of consequtive equal elements +groupSortBy :: (a -> a -> Ordering) -> [a] -> [[a]] +groupSortBy f = groupBy (\x y -> f x y == EQ) . sortBy f + +type ChildVisits = [(Vertex,Int)] + +-- | Helper function for folding over child visits +foldChildVisits :: VGProd -> (ChildVisits, Int) -> Vertex -> VG s (ChildVisits, Int) +foldChildVisits prod (vis,i) v = do + (nvis,ni) <- findChildVisits prod v vis + return (nvis, ni `max` i) + +-- | Recursively find all visits to childs +findChildVisits :: VGProd -> Vertex -> ChildVisits -> VG s (ChildVisits, Int) +findChildVisits prod v vis = do + case lookup v vis of + Just i -> return (vis,i) + Nothing -> do + final <- isDepGraphVertexFinal prod v + if final + then return (vis,0) + else do + succs <- onMarkedDepGraph (liftM Set.toList . flip graphSuccessors v . pdgmDepGraph) prod + (nvis,ni) <- foldM (foldChildVisits prod) (vis,0) succs + if isChildSyn v + then return ((v,ni + 1) : nvis, ni + 1) + else return ((v,ni) : nvis, ni) + +-- | Correct inherited child visits after foldChildVisits +correctInhChilds :: VGProd -> ChildVisits -> VG s ChildVisits +correctInhChilds prod vis = + forM vis $ \(v,i) -> do + if isChildInh v + then do + preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod + let ni = foldl min 99999999 $ mapMaybe (`lookup` vis) preds + return (v,ni) + else if not $ isChildSyn v + then do + succs <- onMarkedDepGraph (liftM Set.toList . flip graphSuccessors v . pdgmDepGraph) prod + let ni = foldl max (-1) $ mapMaybe (`lookup` vis) succs + return (v,ni+1) + else return (v,i) + +-- | Synthesized attributes that can also be evaluated +extraChildSyn :: VGProd -> ChildVisits -> VG s ChildVisits +extraChildSyn prod vis = do + allpreds <- forM vis $ \(v,_) -> do + if isChildInh v + then do + preds <- onMarkedDepGraph (liftM Set.toList . flip graphPredecessors v . pdgmDepGraph) prod + return $ Set.fromList $ filter isChildSyn preds + else return Set.empty + lextravis <- forM (Set.toList $ Set.unions allpreds) $ \v -> do + ready <- isReadyVertex prod vis v + return $ maybe Nothing (\i -> Just (v,i)) ready + return $ catMaybes lextravis + +-- | Check if a vertex can be marked final in this step (and is not final yet) and return the visit num +isReadyVertex :: VGProd -> ChildVisits -> Vertex -> VG s (Maybe Int) +isReadyVertex prod vis v = do + final <- isDepGraphVertexFinal prod v + if v `elem` (map fst vis) || final + then return Nothing + else do + succ <- onMarkedDepGraph (flip graphSuccessors v . pdgmDepGraph) prod + rd <- mapM (\x -> do case lookup x vis of + Just i -> return $ Just i + Nothing -> do fin <- isDepGraphVertexFinal prod x + return $ if fin then Just 1 else Nothing) (Set.toList succ) + if all isJust rd + then return $ Just $ foldl1 max $ catMaybes rd + else return $ Nothing + +-- | Check if this vertex is a synthesized attribute of a child +isChildSyn :: Vertex -> Bool +isChildSyn v = isChildAttr v && getAttrType v == Syn + +-- | Check if this vertex is an inherited attribute of a child +isChildInh :: Vertex -> Bool +isChildInh v = isChildAttr v && getAttrType v == Inh + +-- | Check if this vertex is an attribute of a child +isChildAttr :: Vertex -> Bool +isChildAttr v = isVertexAttr v && getAttrChildName v /= _LHS && getAttrType v /= Loc + +-- | Create lhs.inh vertex +createLhsInh :: Identifier -> Vertex +createLhsInh = VAttr Inh _LHS + +-- | Create lhs.inh vertex +createLhsSyn :: Identifier -> Vertex +createLhsSyn = VAttr Syn _LHS + +------------------------------------------------------------ +--- Construction of the execution plan --- +------------------------------------------------------------ +kennedyWarrenExecutionPlan :: Options -> [NontDependencyInformationM s] -> [[VisitIdentifier]] -> + Set NontermIdent -> TypeSyns -> Derivings -> VG s ExecutionPlan +kennedyWarrenExecutionPlan opts ndis initvs wr typesyns derivings = do + -- Loop over all nonterminals + nonts <- forM (zip ndis initvs) $ \(ndi, initv) -> do + -- Loop over all productions of this nonterminal + prods <- forM (ndimProds ndi) $ \prod -> do + -- Construct the visits for this production + let inont = ndiNonterminal $ ndimOrig ndi + let iprod = pdgProduction $ pdgmOrig prod + prodvs <- gets vgProdVisits + let thisvisits = filter (\((int,ipr,_),_) -> int == inont && ipr == iprod) $ Map.toList prodvs + visits <- forM thisvisits $ \((_,_,vgedg@(VGEdge edg)),rprodvs) -> do + edges <- gets vgEdges + let (VGNode fr, VGNode to) = imLookup edg edges + steps <- vgInST $ readSTRef rprodvs + inh <- getInherited vgedg + syn <- getSynthesized vgedg + let kind | monadic opts = VisitMonadic + | otherwise = VisitPure True + return $ Visit edg fr to inh syn steps kind + -- Return execution plan for this production + return $ EProduction (pdgProduction $ pdgmOrig prod) + (pdgParams $ pdgmOrig prod) + (pdgConstraints $ pdgmOrig prod) + (pdgRules $ pdgmOrig prod) + (pdgChilds $ pdgmOrig prod) + visits + -- Find initial state for this nonterminal + VGNode init <- vgFindInitial $ ndiNonterminal $ ndimOrig ndi + -- Construct an environment that specifies the next visit of the states that have exactly one + nextMap <- mkNextMap init + prevMap <- mkPrevMap init + -- Return execution plan for this nonterminal + return $ ENonterminal (ndiNonterminal $ ndimOrig ndi) + (ndiParams $ ndimOrig ndi) + (ndiClassCtxs $ ndimOrig ndi) + init + initv + nextMap + prevMap + prods + (ndiRecursive $ ndimOrig ndi) + (ndiHoInfo $ ndimOrig ndi) + + -- Return complete execution plan + return $ ExecutionPlan nonts typesyns wr derivings + +------------------------------------------------------------ +--- Construction of the single-exit states map --- +------------------------------------------------------------ + +-- depth-first traversal over the graph that starts at 'init' and maintains a state 'a' +-- the function 'f' can inspect the prev/next edges per state +exploreGraph :: (VGNode -> Set VGEdge -> Set VGEdge -> a -> VG s a) -> VGNode -> a -> VG s a +exploreGraph f (VGNode init) a0 = do + exploredRef <- vgInST $ newSTRef IntSet.empty + pendingRef <- vgInST $ newSTRef [init] + resRef <- vgInST $ newSTRef a0 + outgoingMap <- gets vgOutgoing + edgesInfo <- gets vgEdges + let explore = do + pending <- vgInST $ readSTRef pendingRef + case pending of + [] -> return () + (p:ps) -> do + vgInST $ writeSTRef pendingRef ps + explored <- vgInST $ readSTRef exploredRef + if IntSet.member p explored + then return () + else do + vgInST $ writeSTRef exploredRef (IntSet.insert p explored) + case IntMap.lookup p outgoingMap of + Nothing -> return () + Just outRef -> case IntMap.lookup p outgoingMap of + Nothing -> return () + Just inRef -> do + outSet <- vgInST $ readSTRef outRef + inSet <- vgInST $ readSTRef inRef + sol0 <- vgInST $ readSTRef resRef + sol1 <- f (VGNode p) inSet outSet sol0 + vgInST $ writeSTRef resRef sol1 + forM_ (Set.elems outSet) $ \(VGEdge edge) -> + case IntMap.lookup edge edgesInfo of + Nothing -> return () + Just (_,VGNode to) -> vgInST $ modifySTRef pendingRef (to :) + explore + explore + vgInST $ readSTRef resRef + +mkNextMap :: Int -> VG s (Map Int StateCtx) +mkNextMap start = exploreGraph f (VGNode start) Map.empty where + f (VGNode nd) _ edges = updateCountMap nd edges + +mkPrevMap :: Int -> VG s (Map Int StateCtx) +mkPrevMap start = exploreGraph f (VGNode start) Map.empty where + f (VGNode nd) edges _ = updateCountMap nd edges + +updateCountMap :: Int -> Set VGEdge -> Map Int StateCtx -> VG s (Map Int StateCtx) +updateCountMap nd edges mp = return $ Map.insert nd v mp where + s = Set.size edges + v | s == 0 = NoneVis + | s == 1 = let [VGEdge v'] = Set.elems edges + in OneVis v' + | otherwise = ManyVis diff --git a/src/Knuth1.hs b/src/Knuth1.hs --- a/src/Knuth1.hs +++ b/src/Knuth1.hs @@ -1,532 +1,532 @@ -module Knuth1 where - -import Pretty -import ExecutionPlan -import CommonTypes -import Control.Monad -import Control.Monad.ST -import Data.Maybe -import Data.List -import Data.STRef -import Debug.Trace - -import Data.Array (Array) -import qualified Data.Array as Array -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set - --- | Trace a message in the ST monad -traceST :: String -> ST s () -traceST s = trace s (return ()) - -------------------------------------------------------------------------------- --- Dependency graph representation -------------------------------------------------------------------------------- - --- Vertices -data AttrType = Inh | Syn | Loc deriving (Eq, Ord, Show) -data Vertex = VAttr AttrType Identifier Identifier - | VChild Identifier - | VRule Identifier deriving (Eq, Ord) - -instance Show Vertex where - show (VAttr ty ch at) = show ty ++ " @" ++ show ch ++ "." ++ show at - show (VChild ch) = "Child " ++ show ch - show (VRule ru) = "Rule " ++ show ru - --- | Check if a vertex is an attribute -isVertexAttr :: Vertex -> Bool -isVertexAttr (VAttr _ _ _) = True -isVertexAttr _ = False - --- | Get the child name of an attribute -getAttrChildName :: Vertex -> Identifier -getAttrChildName (VAttr _ n _) = n - --- | Set the child name of an attribute -setAttrChildName :: Vertex -> Identifier -> Vertex -setAttrChildName (VAttr t _ a) n = VAttr t n a - --- | Get the type of an attribute -getAttrType :: Vertex -> AttrType -getAttrType (VAttr t _ _) = t - --- | Get the name of an attribute -getAttrName :: Vertex -> Identifier -getAttrName (VAttr _ _ a) = a - --- Edges -type Edge = (Vertex, Vertex) - --- Internal representation of a vertex -type IVertex = Int -type IEdge = (IVertex, IVertex) - --- Representation of the graph -data DependencyGraph s = DependencyGraph { vertexIMap :: Map Vertex IVertex - , vertexOMap :: Array IVertex Vertex - , successors :: Array IVertex (STRef s (Set IVertex)) - , predecessors :: Array IVertex (STRef s (Set IVertex)) } - -------------------------------------------------------------------------------- --- Dependency graph fuctions -------------------------------------------------------------------------------- - --- | Construct a dependency graph -graphConstruct :: [Vertex] -> ST s (DependencyGraph s) -graphConstruct vs = do let nv = length vs - let ivs = [0..nv-1] - let ivb = (0,nv-1) - let vimap = Map.fromList (zip vs ivs) - let vomap = Array.array ivb (zip ivs vs) - succs <- replicateM nv (newSTRef Set.empty) - preds <- replicateM nv (newSTRef Set.empty) - let su = Array.array ivb (zip ivs succs) - let pr = Array.array ivb (zip ivs preds) - let graph = DependencyGraph { vertexIMap = vimap - , vertexOMap = vomap - , successors = su - , predecessors = pr } - return graph - --- | Construct a transitivelly closed graph -graphConstructTRC :: [Vertex] -> [Edge] -> ST s (DependencyGraph s) -graphConstructTRC vs es = do g <- graphConstruct vs - -- Insert all initial edges - graphInsertEdgesTRC g es - return g - --- | Return all successors of a vertex -graphSuccessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex) -graphSuccessors g v = do sucs <- readSTRef $ (successors g) Array.! (graphGetIVertex g v) - return $ Set.map (graphGetVertex g) sucs - --- | Return all predecessors of a vertex -graphPredecessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex) -graphPredecessors g v = do sucs <- readSTRef $ (predecessors g) Array.! (graphGetIVertex g v) - return $ Set.map (graphGetVertex g) sucs - --- | Check if the graph contains an edge -graphContainsEdge :: DependencyGraph s -> Edge -> ST s Bool -graphContainsEdge g (v1,v2) = do let iv1 = graphGetIVertex g v1 - let iv2 = graphGetIVertex g v2 - sucs <- readSTRef $ (successors g) Array.! iv1 - return $ iv2 `Set.member` sucs - --- | Insert an edge in the graph -graphInsert :: DependencyGraph s -> Edge -> ST s () -graphInsert g (v1,v2) = do let iv1 = graphGetIVertex g v1 - let iv2 = graphGetIVertex g v2 - -- Add v2 to the successors of v1 and v1 to predecessors of v2 - modifySTRef ((successors g) Array.! iv1) $ Set.insert iv2 - modifySTRef ((predecessors g) Array.! iv2) $ Set.insert iv1 - --- | Insert an edge in a transtive closed graph and return all other edges that were --- added due to transtivity -graphInsertTRC :: DependencyGraph s -> Edge -> ST s [(IVertex, Set IVertex)] -graphInsertTRC g (v1,v2) = do let iv1 = graphGetIVertex g v1 - let iv2 = graphGetIVertex g v2 - -- Read predecessors of v1 and successors of v2 - pred1 <- readSTRef $ (predecessors g) Array.! iv1 - succ2 <- readSTRef $ (successors g) Array.! iv2 - -- First insert all edges from v1 - let rsucc1 = (successors g) Array.! iv1 - succ1 <- readSTRef rsucc1 - let add1 = succ2 `Set.difference` succ1 - modifySTRef rsucc1 (Set.union add1 . Set.insert iv2) - -- All edges to v2 - let rpred2 = (predecessors g) Array.! iv2 - modifySTRef rpred2 (Set.union pred1 . Set.insert iv1) - -- Connect every predecessor of v1 to every successor of v2 - sucl <- forM (Set.toList pred1) $ \pred -> do - -- Connect pred to v2 and all successors of v2 - let rsucc = (successors g) Array.! pred - csucc <- readSTRef rsucc - let cadd = (Set.insert iv2 succ2) `Set.difference` csucc - modifySTRef rsucc (Set.union cadd) - return (pred, cadd) - -- Connect every successor of v2 to every predecessor of v1 - forM_ (Set.toList succ2) $ \succ -> do - -- Connect succ to v1 and all predecessors of v1 - let rpred = (predecessors g) Array.! succ - cpred <- readSTRef rpred - let cadd = (Set.insert iv1 pred1) `Set.difference` cpred - modifySTRef rpred (Set.union cadd) - -- Create return - return $ (iv1,add1) : sucl - --- | Return all vertices of the graph -graphVertices :: DependencyGraph s -> ST s [Vertex] -graphVertices = return . Array.elems . vertexOMap - --- | Return all edges of the graph -graphEdges :: DependencyGraph s -> ST s [Edge] -graphEdges g = do let vs = Array.indices $ vertexOMap g - perv <- forM vs $ \v -> do - let rv = graphGetVertex g v - sucs <- readSTRef $ (successors g) Array.! v - let sucl = Set.toList sucs - return $ map ((,) rv . graphGetVertex g) sucl - return $ concat perv - --- | Insert a list of edges in the graph -graphInsertEdges :: DependencyGraph s -> [Edge] -> ST s () -graphInsertEdges g ed = mapM_ (graphInsert g) ed - --- | Insert a list of edges in the graph and return all other edges that --- were added due to transitivity -graphInsertEdgesTRC :: DependencyGraph s -> [Edge] -> ST s [Edge] -graphInsertEdgesTRC g ed = do -- rets :: [[(IVertex, Set IVertex)]] - rets <- mapM (graphInsertTRC g) ed - -- Combine all successor sets - let f :: (IVertex, (Set IVertex)) -> [(IVertex, IVertex)] - f (v,s) = map ((,) v) (Set.toList s) - let comb :: [(IVertex, IVertex)] - comb = concatMap (concatMap f) rets - -- Construct edges from this - return $ map (graphGetEdge g) $ comb - --- | Check whether the graph is cyclic -graphIsCyclic :: DependencyGraph s -> ST s Bool -graphIsCyclic g = do - s <- graphCyclicVertices g - return $ not $ Set.null s - -graphCyclicVertices :: DependencyGraph s -> ST s (Set IVertex) -graphCyclicVertices g = do - vs <- return $ Array.indices $ vertexOMap g - sets <- forM vs $ \v -> do - sucs <- readSTRef $ (successors g) Array.! v - let res | v `Set.member` sucs = Set.singleton v - | otherwise = Set.empty - return res - return (Set.unions sets) - -graphCyclicVerticesExt :: DependencyGraph s -> ST s [Vertex] -graphCyclicVerticesExt g = (map (graphGetVertex g) . Set.elems) `fmap` graphCyclicVertices g - --- | Get internal representation of a vertex -graphGetIVertex :: DependencyGraph s -> Vertex -> IVertex -graphGetIVertex g v = vertexIMap g Map.! v - --- | Get external representation of a vertex -graphGetVertex :: DependencyGraph s -> IVertex -> Vertex -graphGetVertex g v = vertexOMap g Array.! v - --- | Get external representation of an edge -graphGetEdge :: DependencyGraph s -> IEdge -> Edge -graphGetEdge g (v1,v2) = (graphGetVertex g v1, graphGetVertex g v2) - --- | Check if the graph is transitively closed -graphIsTRC :: DependencyGraph s -> ST s Bool -graphIsTRC g = do let vs = Array.indices $ vertexOMap g - bs <- forM vs $ \v -> do - succs <- readSTRef $ (successors g) Array.! v - bs2 <- forM (Set.toList succs) $ \v2 -> do - succs2 <- readSTRef $ (successors g) Array.! v2 - return $ succs2 `Set.isSubsetOf` succs - return $ and bs2 - return $ and bs - --- | Check consistency of the graph (successor and predecessor sets) -graphCheckConsistency :: DependencyGraph s -> ST s Bool -graphCheckConsistency g = do let vs = Array.indices $ vertexOMap g - ret <- forM vs $ \v -> do - -- V must appear in every predecessor set of its successors - succs <- readSTRef $ (successors g) Array.! v - r1 <- forM (Set.toList succs) $ \succ -> do - preds2 <- readSTRef $ (predecessors g) Array.! succ - return (v `Set.member` preds2) - -- V must appear in every successor set of its predecessors - preds <- readSTRef $ (predecessors g) Array.! v - r2 <- forM (Set.toList preds) $ \pred -> do - succs2 <- readSTRef $ (successors g) Array.! pred - return (v `Set.member` succs2) - return $ and $ r1 ++ r2 - return $ and $ ret - --- | Add edges to the graph so that it is topologically sorted (this will not work if graph is cyclic) -graphTopSort :: DependencyGraph s -> ST s [Edge] -graphTopSort g = do let vs = Array.indices $ vertexOMap g - order <- foldM (graphTopSort' g) [] vs - mb <- forM (zip order (tail order)) $ \(v1,v2) -> do - let edg = graphGetEdge g (v2,v1) -- order is actually reverse order - ce <- graphContainsEdge g edg - if ce - then return Nothing - else do graphInsert g edg - return $ Just edg - return $ catMaybes mb - --- | Helper function for graphTopSort -graphTopSort' :: DependencyGraph s -> [IVertex] -> IVertex -> ST s [IVertex] -graphTopSort' g prev cur | cur `elem` prev = return prev - | otherwise = do pred <- readSTRef $ (predecessors g) Array.! cur - order <- foldM (graphTopSort' g) prev $ Set.toList pred - return $ cur : order - -------------------------------------------------------------------------------- --- Dependency graph information wrappers -------------------------------------------------------------------------------- - --- | Special wrapper for nonterminal dependency graphs (so that we can easily add other meta-information) -data NontDependencyGraph = NontDependencyGraph { ndgVertices :: [Vertex] - , ndgEdges :: [Edge] } - --- | Special wrapper for production dependency graphs, including mapping between child names and nonterminals -data ProdDependencyGraph = ProdDependencyGraph { pdgVertices :: [Vertex] - , pdgEdges :: [Edge] - , pdgRules :: ERules - , pdgChilds :: EChildren - , pdgProduction :: Identifier - , pdgChildMap :: [(Identifier, Identifier)] - , pdgConstraints :: [Type] - , pdgParams :: [Identifier] } - - --- | Represent all information from the dependency graphs for a nonterminal -data NontDependencyInformation = NontDependencyInformation { ndiNonterminal :: Identifier - , ndiParams :: [Identifier] - , ndiInh :: [Identifier] - , ndiSyn :: [Identifier] - , ndiDepGraph :: NontDependencyGraph - , ndiProds :: [ProdDependencyGraph] - , ndiRecursive :: Bool - , ndiHoInfo :: HigherOrderInfo - , ndiClassCtxs :: ClassContext - } - ---- Monadic versions of these records, for use with the ST monad - --- | Monadic wrapper of NontDependencyGraph -data NontDependencyGraphM s = NontDependencyGraphM { ndgmDepGraph :: DependencyGraph s - , ndgmOrig :: NontDependencyGraph } - --- | Monadic wrapper of ProdDependencyGraph -data ProdDependencyGraphM s = ProdDependencyGraphM { pdgmDepGraph :: DependencyGraph s - , pdgmOrig :: ProdDependencyGraph } - - --- | Monadic wrapper of NontDependencyInformation -data NontDependencyInformationM s = NontDependencyInformationM { ndimOrig :: NontDependencyInformation - , ndimDepGraph :: NontDependencyGraphM s - , ndimProds :: [ProdDependencyGraphM s] } - - --- | Convert a NontDependencyGraph to the corresponding monadic version -mkNontDependencyGraphM :: NontDependencyGraph -> ST s (NontDependencyGraphM s) -mkNontDependencyGraphM ndg = do g <- graphConstructTRC (ndgVertices ndg) (ndgEdges ndg) - return $ NontDependencyGraphM { ndgmDepGraph = g - , ndgmOrig = ndg } - - --- | Convert a ProdDependencyGraph to the corresponding monadic version -mkProdDependencyGraphM :: Bool -> ProdDependencyGraph -> ST s (ProdDependencyGraphM s) -mkProdDependencyGraphM trc pdg = do g <- if trc - then graphConstructTRC (pdgVertices pdg) (pdgEdges pdg) - else do g <- graphConstruct (pdgVertices pdg) - mapM_ (graphInsert g) (pdgEdges pdg) - return g - return $ ProdDependencyGraphM { pdgmDepGraph = g - , pdgmOrig = pdg } - --- | Convert a NontDependencyInformation to the corresponding monadic version -mkNontDependencyInformationM :: NontDependencyInformation -> ST s (NontDependencyInformationM s) -mkNontDependencyInformationM ndi = do dg <- mkNontDependencyGraphM (ndiDepGraph ndi) - prods <- mapM (mkProdDependencyGraphM True) (ndiProds ndi) - return $ NontDependencyInformationM { ndimOrig = ndi - , ndimDepGraph = dg - , ndimProds = prods } - --- | Construct the production graphs from the transitivelly closed graphs -undoTransitiveClosure :: [NontDependencyInformationM s] -> ST s [NontDependencyInformationM s] -undoTransitiveClosure ndis = do edgesl <- mapM (\ndi -> graphEdges (ndgmDepGraph $ ndimDepGraph ndi)) ndis - let edges = concat edgesl - forM ndis $ \ndi -> do - prods <- mapM (mkProdDependencyGraphM False) (ndiProds $ ndimOrig ndi) - forM_ (zip prods (ndimProds ndi)) $ \(nprod,oprod) -> do - -- All possible edges - let possa = do (v1,v2) <- edges - -- Take a child of this nonterminal type - guard $ isVertexAttr v1 - guard $ isVertexAttr v2 - let tp = getAttrChildName v1 - (ch,chtp) <- pdgChildMap $ pdgmOrig nprod - guard $ tp == chtp - -- Construct edge as it should be in the production graph - let nv1 = setAttrChildName v1 ch - let nv2 = setAttrChildName v2 ch - return (nv1, nv2) - toadd <- filterM (graphContainsEdge (pdgmDepGraph oprod)) possa - graphInsertEdges (pdgmDepGraph nprod) toadd - return $ NontDependencyInformationM { ndimOrig = ndimOrig ndi - , ndimDepGraph = ndimDepGraph ndi - , ndimProds = prods } - - -------------------------------------------------------------------------------- --- Knuth-1 algorithm -------------------------------------------------------------------------------- - --- | Combine the dependency and nonterminal graphs using Knuth-1 --- this function assumes that the nonterminal graphs initially contains no edges -knuth1 :: [NontDependencyInformationM s] -> ST s () -knuth1 ndis = do -- Create initial list of pending edges for each ndi per production (initially all prod edges) --- pndis :: [([[Edge]], NontDependencyInformation)] - pndis <- forM ndis $ \ndi -> do - ipend <- mapM (graphEdges . pdgmDepGraph) . ndimProds $ ndi - return (ipend, ndi) - knuth1' pndis - --- | Helper function for |knuth1| which repeats the process until we are done -knuth1' :: [([[Edge]], NontDependencyInformationM s)] -> ST s () -knuth1' ndis = do -- Add edges from the production graphs to the nonterminal graph --- ndis' :: [[Edge]] - ndis' <- mapM addProdNont ndis - -- List of all newly added edges --- ntedge :: [Edge] - let pntedge = concat ndis' - -- Add backedges - --bedges <- addBackEdges ndis - -- All added nonterminal edges - let ntedge = pntedge -- ++ bedges - if null ntedge - -- When no new edges have been added we are done - then return () - else do -- Otherwise, the next step is to add edges from nonterminal to production graphs --- ndis'' :: [[[Edge]]] - ndis'' <- mapM (\(_,x) -> addNontProd True (ntedge, x)) ndis - -- List of new states (production edges + dependency graphs) --- nndis' :: [([[Edge]], NontDependencyInformation)] - nndis' <- zipWithM (\(_,ndi) me -> return (me, ndi)) ndis ndis'' - if any (not . null) ndis'' - -- We have added some edges, so continue the process - then knuth1' nndis' - -- No new edges added, we are done - else return () - --- | Add pending edges from the production graphs to the nonterminal graph --- and return the list of newly added nonterminal edges -addProdNont :: ([[Edge]], NontDependencyInformationM s) -> ST s [Edge] -addProdNont (pending, ndi) = do -- Unwrapping of the records - let nontDepGraph = ndimDepGraph ndi - let nontGraph = ndgmDepGraph nontDepGraph - -- nub the list because multiple productions can result in the same new edges - let possa = nub $ do (v1,v2) <- concat pending - -- Take only edges from syn.lhs to inh.lhs - guard $ isVertexAttr v1 - guard $ getAttrChildName v1 == _LHS - guard $ getAttrType v1 == Syn - guard $ isVertexAttr v2 - guard $ getAttrChildName v2 == _LHS - guard $ getAttrType v2 == Inh - -- Construct edge as it should be in nonterminal graph - let nv1 = setAttrChildName v1 (ndiNonterminal $ ndimOrig ndi) - let nv2 = setAttrChildName v2 (ndiNonterminal $ ndimOrig ndi) - return (nv1, nv2) - -- Edges that are not in the nonterminal graph yet - toadd <- filterM (\e -> return not `ap` graphContainsEdge nontGraph e) possa - -- Check whether new edges are to be added and return the added edges - when (not $ null toadd) $ do - graphInsertEdgesTRC nontGraph toadd - return () - return toadd - --- | Add edges from the nonterminal graphs to the production graphs --- and return the list of newly added production edges and the updated graph -addNontProd :: Bool -> ([Edge], NontDependencyInformationM s) -> ST s [[Edge]] -addNontProd trc (pending, ndi) = do -- Just call the helper function for each nonterminal - mapM (addNontProd' trc pending) (ndimProds ndi) - --- | Helper function for |addNontProd| for a single production -addNontProd' :: Bool -> [Edge] -> ProdDependencyGraphM s -> ST s [Edge] -addNontProd' trc pend pdg = do -- Unwrapping of the records - prodGraph <- return $ pdgmDepGraph pdg - -- Construct all possible new edges - let possa = do (v1,v2) <- pend - -- Take a child of this nonterminal type - guard $ isVertexAttr v1 - guard $ isVertexAttr v2 - let tp = getAttrChildName v1 - (ch,chtp) <- pdgChildMap $ pdgmOrig pdg - guard $ tp == chtp - -- Construct edge as it should be in the production graph - let nv1 = setAttrChildName v1 ch - let nv2 = setAttrChildName v2 ch - return (nv1, nv2) - -- Edges that are not in the production graph yet - toadd <- filterM (\e -> return not `ap` graphContainsEdge prodGraph e) possa - -- Check whether new edges are to be added and return the result - if null toadd - then return [] - else do -- Insert all edges and return transitive edges that are added in this process - ret <- if trc - then graphInsertEdgesTRC prodGraph toadd - else do mapM_ (graphInsert prodGraph) toadd - return [] - -- Debug output - --mapM_ (\edge -> traceST $ "Adding production edge " ++ show edge) toadd - return ret - --- | Add the "back edges" to the nonterminal graphs for creating a global ordering -addBackEdges :: [([[Edge]], NontDependencyInformationM s)] -> ST s [Edge] -addBackEdges ndis = do -- gather all backedges - lBackEdges <- forM ndis $ \(aedg,ndi) -> do - -- For every production - bs <- forM (zip aedg (ndimProds ndi)) $ \(edg,prod) -> do - -- Filter out the backedges - return $ do (v1,v2) <- edg - -- Backedges are from inh.ch to syn.ch - guard $ isVertexAttr v1 - guard $ getAttrChildName v1 /= _LHS - guard $ getAttrType v1 == Inh - guard $ isVertexAttr v2 - guard $ getAttrChildName v2 /= _LHS - guard $ getAttrType v2 == Syn - guard $ getAttrChildName v1 == getAttrChildName v2 - -- Find the correct child name - (ch,chtp) <- pdgChildMap $ pdgmOrig prod - let tp = getAttrChildName v1 - guard $ tp == ch - -- Construct the edge as it should be in the nonterminal graph - let nv1 = setAttrChildName v1 chtp - let nv2 = setAttrChildName v2 chtp - return (nv1, nv2) - return $ foldl' union [] bs - -- Concatenate all lists of backedges - let backedges = foldl' union [] lBackEdges - -- Add backedges to every nonterminal graph - ret <- forM ndis $ \(_,ndi) -> do - -- Find the backedges for this nonterminal - let nont = ndiNonterminal . ndimOrig $ ndi - let thisbe = filter ((==) nont . getAttrChildName . fst) backedges - -- Add them to the graph - graphInsertEdgesTRC (ndgmDepGraph . ndimDepGraph $ ndi) thisbe - return $ backedges ++ concat ret - - --- | Add all resulting edges from a topsort on the nonterminal graph to the production graph --- this will ignore edges that will make the graph cyclic -addTopSortEdges :: [Edge] -> ProdDependencyGraphM s -> ST s () -addTopSortEdges pend pdg = do -- Unwrapping of the records - prodGraph <- return $ pdgmDepGraph pdg - -- Construct all possible new edges - let possa = do (v1,v2) <- pend - -- Take a child of this nonterminal type - guard $ isVertexAttr v1 - guard $ isVertexAttr v2 - let tp = getAttrChildName v1 - (ch,chtp) <- pdgChildMap $ pdgmOrig pdg - guard $ tp == chtp - -- Construct edge as it should be in the production graph - let nv1 = setAttrChildName v1 ch - let nv2 = setAttrChildName v2 ch - return (nv1, nv2) - -- Edges that are not in the production graph yet - forM_ possa $ \(v1,v2) -> do e1 <- graphContainsEdge prodGraph (v1,v2) - e2 <- graphContainsEdge prodGraph (v2,v1) - when (not $ e1 || e2) $ do - graphInsertTRC prodGraph (v1,v2) - return () +module Knuth1 where + +import Pretty +import ExecutionPlan +import CommonTypes +import Control.Monad +import Control.Monad.ST +import Data.Maybe +import Data.List +import Data.STRef +import Debug.Trace + +import Data.Array (Array) +import qualified Data.Array as Array +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + +-- | Trace a message in the ST monad +traceST :: String -> ST s () +traceST s = trace s (return ()) + +------------------------------------------------------------------------------- +-- Dependency graph representation +------------------------------------------------------------------------------- + +-- Vertices +data AttrType = Inh | Syn | Loc deriving (Eq, Ord, Show) +data Vertex = VAttr AttrType Identifier Identifier + | VChild Identifier + | VRule Identifier deriving (Eq, Ord) + +instance Show Vertex where + show (VAttr ty ch at) = show ty ++ " @" ++ show ch ++ "." ++ show at + show (VChild ch) = "Child " ++ show ch + show (VRule ru) = "Rule " ++ show ru + +-- | Check if a vertex is an attribute +isVertexAttr :: Vertex -> Bool +isVertexAttr (VAttr _ _ _) = True +isVertexAttr _ = False + +-- | Get the child name of an attribute +getAttrChildName :: Vertex -> Identifier +getAttrChildName (VAttr _ n _) = n + +-- | Set the child name of an attribute +setAttrChildName :: Vertex -> Identifier -> Vertex +setAttrChildName (VAttr t _ a) n = VAttr t n a + +-- | Get the type of an attribute +getAttrType :: Vertex -> AttrType +getAttrType (VAttr t _ _) = t + +-- | Get the name of an attribute +getAttrName :: Vertex -> Identifier +getAttrName (VAttr _ _ a) = a + +-- Edges +type Edge = (Vertex, Vertex) + +-- Internal representation of a vertex +type IVertex = Int +type IEdge = (IVertex, IVertex) + +-- Representation of the graph +data DependencyGraph s = DependencyGraph { vertexIMap :: Map Vertex IVertex + , vertexOMap :: Array IVertex Vertex + , successors :: Array IVertex (STRef s (Set IVertex)) + , predecessors :: Array IVertex (STRef s (Set IVertex)) } + +------------------------------------------------------------------------------- +-- Dependency graph fuctions +------------------------------------------------------------------------------- + +-- | Construct a dependency graph +graphConstruct :: [Vertex] -> ST s (DependencyGraph s) +graphConstruct vs = do let nv = length vs + let ivs = [0..nv-1] + let ivb = (0,nv-1) + let vimap = Map.fromList (zip vs ivs) + let vomap = Array.array ivb (zip ivs vs) + succs <- replicateM nv (newSTRef Set.empty) + preds <- replicateM nv (newSTRef Set.empty) + let su = Array.array ivb (zip ivs succs) + let pr = Array.array ivb (zip ivs preds) + let graph = DependencyGraph { vertexIMap = vimap + , vertexOMap = vomap + , successors = su + , predecessors = pr } + return graph + +-- | Construct a transitivelly closed graph +graphConstructTRC :: [Vertex] -> [Edge] -> ST s (DependencyGraph s) +graphConstructTRC vs es = do g <- graphConstruct vs + -- Insert all initial edges + graphInsertEdgesTRC g es + return g + +-- | Return all successors of a vertex +graphSuccessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex) +graphSuccessors g v = do sucs <- readSTRef $ (successors g) Array.! (graphGetIVertex g v) + return $ Set.map (graphGetVertex g) sucs + +-- | Return all predecessors of a vertex +graphPredecessors :: DependencyGraph s -> Vertex -> ST s (Set Vertex) +graphPredecessors g v = do sucs <- readSTRef $ (predecessors g) Array.! (graphGetIVertex g v) + return $ Set.map (graphGetVertex g) sucs + +-- | Check if the graph contains an edge +graphContainsEdge :: DependencyGraph s -> Edge -> ST s Bool +graphContainsEdge g (v1,v2) = do let iv1 = graphGetIVertex g v1 + let iv2 = graphGetIVertex g v2 + sucs <- readSTRef $ (successors g) Array.! iv1 + return $ iv2 `Set.member` sucs + +-- | Insert an edge in the graph +graphInsert :: DependencyGraph s -> Edge -> ST s () +graphInsert g (v1,v2) = do let iv1 = graphGetIVertex g v1 + let iv2 = graphGetIVertex g v2 + -- Add v2 to the successors of v1 and v1 to predecessors of v2 + modifySTRef ((successors g) Array.! iv1) $ Set.insert iv2 + modifySTRef ((predecessors g) Array.! iv2) $ Set.insert iv1 + +-- | Insert an edge in a transtive closed graph and return all other edges that were +-- added due to transtivity +graphInsertTRC :: DependencyGraph s -> Edge -> ST s [(IVertex, Set IVertex)] +graphInsertTRC g (v1,v2) = do let iv1 = graphGetIVertex g v1 + let iv2 = graphGetIVertex g v2 + -- Read predecessors of v1 and successors of v2 + pred1 <- readSTRef $ (predecessors g) Array.! iv1 + succ2 <- readSTRef $ (successors g) Array.! iv2 + -- First insert all edges from v1 + let rsucc1 = (successors g) Array.! iv1 + succ1 <- readSTRef rsucc1 + let add1 = succ2 `Set.difference` succ1 + modifySTRef rsucc1 (Set.union add1 . Set.insert iv2) + -- All edges to v2 + let rpred2 = (predecessors g) Array.! iv2 + modifySTRef rpred2 (Set.union pred1 . Set.insert iv1) + -- Connect every predecessor of v1 to every successor of v2 + sucl <- forM (Set.toList pred1) $ \pred -> do + -- Connect pred to v2 and all successors of v2 + let rsucc = (successors g) Array.! pred + csucc <- readSTRef rsucc + let cadd = (Set.insert iv2 succ2) `Set.difference` csucc + modifySTRef rsucc (Set.union cadd) + return (pred, cadd) + -- Connect every successor of v2 to every predecessor of v1 + forM_ (Set.toList succ2) $ \succ -> do + -- Connect succ to v1 and all predecessors of v1 + let rpred = (predecessors g) Array.! succ + cpred <- readSTRef rpred + let cadd = (Set.insert iv1 pred1) `Set.difference` cpred + modifySTRef rpred (Set.union cadd) + -- Create return + return $ (iv1,add1) : sucl + +-- | Return all vertices of the graph +graphVertices :: DependencyGraph s -> ST s [Vertex] +graphVertices = return . Array.elems . vertexOMap + +-- | Return all edges of the graph +graphEdges :: DependencyGraph s -> ST s [Edge] +graphEdges g = do let vs = Array.indices $ vertexOMap g + perv <- forM vs $ \v -> do + let rv = graphGetVertex g v + sucs <- readSTRef $ (successors g) Array.! v + let sucl = Set.toList sucs + return $ map ((,) rv . graphGetVertex g) sucl + return $ concat perv + +-- | Insert a list of edges in the graph +graphInsertEdges :: DependencyGraph s -> [Edge] -> ST s () +graphInsertEdges g ed = mapM_ (graphInsert g) ed + +-- | Insert a list of edges in the graph and return all other edges that +-- were added due to transitivity +graphInsertEdgesTRC :: DependencyGraph s -> [Edge] -> ST s [Edge] +graphInsertEdgesTRC g ed = do -- rets :: [[(IVertex, Set IVertex)]] + rets <- mapM (graphInsertTRC g) ed + -- Combine all successor sets + let f :: (IVertex, (Set IVertex)) -> [(IVertex, IVertex)] + f (v,s) = map ((,) v) (Set.toList s) + let comb :: [(IVertex, IVertex)] + comb = concatMap (concatMap f) rets + -- Construct edges from this + return $ map (graphGetEdge g) $ comb + +-- | Check whether the graph is cyclic +graphIsCyclic :: DependencyGraph s -> ST s Bool +graphIsCyclic g = do + s <- graphCyclicVertices g + return $ not $ Set.null s + +graphCyclicVertices :: DependencyGraph s -> ST s (Set IVertex) +graphCyclicVertices g = do + vs <- return $ Array.indices $ vertexOMap g + sets <- forM vs $ \v -> do + sucs <- readSTRef $ (successors g) Array.! v + let res | v `Set.member` sucs = Set.singleton v + | otherwise = Set.empty + return res + return (Set.unions sets) + +graphCyclicVerticesExt :: DependencyGraph s -> ST s [Vertex] +graphCyclicVerticesExt g = (map (graphGetVertex g) . Set.elems) `fmap` graphCyclicVertices g + +-- | Get internal representation of a vertex +graphGetIVertex :: DependencyGraph s -> Vertex -> IVertex +graphGetIVertex g v = vertexIMap g Map.! v + +-- | Get external representation of a vertex +graphGetVertex :: DependencyGraph s -> IVertex -> Vertex +graphGetVertex g v = vertexOMap g Array.! v + +-- | Get external representation of an edge +graphGetEdge :: DependencyGraph s -> IEdge -> Edge +graphGetEdge g (v1,v2) = (graphGetVertex g v1, graphGetVertex g v2) + +-- | Check if the graph is transitively closed +graphIsTRC :: DependencyGraph s -> ST s Bool +graphIsTRC g = do let vs = Array.indices $ vertexOMap g + bs <- forM vs $ \v -> do + succs <- readSTRef $ (successors g) Array.! v + bs2 <- forM (Set.toList succs) $ \v2 -> do + succs2 <- readSTRef $ (successors g) Array.! v2 + return $ succs2 `Set.isSubsetOf` succs + return $ and bs2 + return $ and bs + +-- | Check consistency of the graph (successor and predecessor sets) +graphCheckConsistency :: DependencyGraph s -> ST s Bool +graphCheckConsistency g = do let vs = Array.indices $ vertexOMap g + ret <- forM vs $ \v -> do + -- V must appear in every predecessor set of its successors + succs <- readSTRef $ (successors g) Array.! v + r1 <- forM (Set.toList succs) $ \succ -> do + preds2 <- readSTRef $ (predecessors g) Array.! succ + return (v `Set.member` preds2) + -- V must appear in every successor set of its predecessors + preds <- readSTRef $ (predecessors g) Array.! v + r2 <- forM (Set.toList preds) $ \pred -> do + succs2 <- readSTRef $ (successors g) Array.! pred + return (v `Set.member` succs2) + return $ and $ r1 ++ r2 + return $ and $ ret + +-- | Add edges to the graph so that it is topologically sorted (this will not work if graph is cyclic) +graphTopSort :: DependencyGraph s -> ST s [Edge] +graphTopSort g = do let vs = Array.indices $ vertexOMap g + order <- foldM (graphTopSort' g) [] vs + mb <- forM (zip order (tail order)) $ \(v1,v2) -> do + let edg = graphGetEdge g (v2,v1) -- order is actually reverse order + ce <- graphContainsEdge g edg + if ce + then return Nothing + else do graphInsert g edg + return $ Just edg + return $ catMaybes mb + +-- | Helper function for graphTopSort +graphTopSort' :: DependencyGraph s -> [IVertex] -> IVertex -> ST s [IVertex] +graphTopSort' g prev cur | cur `elem` prev = return prev + | otherwise = do pred <- readSTRef $ (predecessors g) Array.! cur + order <- foldM (graphTopSort' g) prev $ Set.toList pred + return $ cur : order + +------------------------------------------------------------------------------- +-- Dependency graph information wrappers +------------------------------------------------------------------------------- + +-- | Special wrapper for nonterminal dependency graphs (so that we can easily add other meta-information) +data NontDependencyGraph = NontDependencyGraph { ndgVertices :: [Vertex] + , ndgEdges :: [Edge] } + +-- | Special wrapper for production dependency graphs, including mapping between child names and nonterminals +data ProdDependencyGraph = ProdDependencyGraph { pdgVertices :: [Vertex] + , pdgEdges :: [Edge] + , pdgRules :: ERules + , pdgChilds :: EChildren + , pdgProduction :: Identifier + , pdgChildMap :: [(Identifier, Identifier)] + , pdgConstraints :: [Type] + , pdgParams :: [Identifier] } + + +-- | Represent all information from the dependency graphs for a nonterminal +data NontDependencyInformation = NontDependencyInformation { ndiNonterminal :: Identifier + , ndiParams :: [Identifier] + , ndiInh :: [Identifier] + , ndiSyn :: [Identifier] + , ndiDepGraph :: NontDependencyGraph + , ndiProds :: [ProdDependencyGraph] + , ndiRecursive :: Bool + , ndiHoInfo :: HigherOrderInfo + , ndiClassCtxs :: ClassContext + } + +--- Monadic versions of these records, for use with the ST monad + +-- | Monadic wrapper of NontDependencyGraph +data NontDependencyGraphM s = NontDependencyGraphM { ndgmDepGraph :: DependencyGraph s + , ndgmOrig :: NontDependencyGraph } + +-- | Monadic wrapper of ProdDependencyGraph +data ProdDependencyGraphM s = ProdDependencyGraphM { pdgmDepGraph :: DependencyGraph s + , pdgmOrig :: ProdDependencyGraph } + + +-- | Monadic wrapper of NontDependencyInformation +data NontDependencyInformationM s = NontDependencyInformationM { ndimOrig :: NontDependencyInformation + , ndimDepGraph :: NontDependencyGraphM s + , ndimProds :: [ProdDependencyGraphM s] } + + +-- | Convert a NontDependencyGraph to the corresponding monadic version +mkNontDependencyGraphM :: NontDependencyGraph -> ST s (NontDependencyGraphM s) +mkNontDependencyGraphM ndg = do g <- graphConstructTRC (ndgVertices ndg) (ndgEdges ndg) + return $ NontDependencyGraphM { ndgmDepGraph = g + , ndgmOrig = ndg } + + +-- | Convert a ProdDependencyGraph to the corresponding monadic version +mkProdDependencyGraphM :: Bool -> ProdDependencyGraph -> ST s (ProdDependencyGraphM s) +mkProdDependencyGraphM trc pdg = do g <- if trc + then graphConstructTRC (pdgVertices pdg) (pdgEdges pdg) + else do g <- graphConstruct (pdgVertices pdg) + mapM_ (graphInsert g) (pdgEdges pdg) + return g + return $ ProdDependencyGraphM { pdgmDepGraph = g + , pdgmOrig = pdg } + +-- | Convert a NontDependencyInformation to the corresponding monadic version +mkNontDependencyInformationM :: NontDependencyInformation -> ST s (NontDependencyInformationM s) +mkNontDependencyInformationM ndi = do dg <- mkNontDependencyGraphM (ndiDepGraph ndi) + prods <- mapM (mkProdDependencyGraphM True) (ndiProds ndi) + return $ NontDependencyInformationM { ndimOrig = ndi + , ndimDepGraph = dg + , ndimProds = prods } + +-- | Construct the production graphs from the transitivelly closed graphs +undoTransitiveClosure :: [NontDependencyInformationM s] -> ST s [NontDependencyInformationM s] +undoTransitiveClosure ndis = do edgesl <- mapM (\ndi -> graphEdges (ndgmDepGraph $ ndimDepGraph ndi)) ndis + let edges = concat edgesl + forM ndis $ \ndi -> do + prods <- mapM (mkProdDependencyGraphM False) (ndiProds $ ndimOrig ndi) + forM_ (zip prods (ndimProds ndi)) $ \(nprod,oprod) -> do + -- All possible edges + let possa = do (v1,v2) <- edges + -- Take a child of this nonterminal type + guard $ isVertexAttr v1 + guard $ isVertexAttr v2 + let tp = getAttrChildName v1 + (ch,chtp) <- pdgChildMap $ pdgmOrig nprod + guard $ tp == chtp + -- Construct edge as it should be in the production graph + let nv1 = setAttrChildName v1 ch + let nv2 = setAttrChildName v2 ch + return (nv1, nv2) + toadd <- filterM (graphContainsEdge (pdgmDepGraph oprod)) possa + graphInsertEdges (pdgmDepGraph nprod) toadd + return $ NontDependencyInformationM { ndimOrig = ndimOrig ndi + , ndimDepGraph = ndimDepGraph ndi + , ndimProds = prods } + + +------------------------------------------------------------------------------- +-- Knuth-1 algorithm +------------------------------------------------------------------------------- + +-- | Combine the dependency and nonterminal graphs using Knuth-1 +-- this function assumes that the nonterminal graphs initially contains no edges +knuth1 :: [NontDependencyInformationM s] -> ST s () +knuth1 ndis = do -- Create initial list of pending edges for each ndi per production (initially all prod edges) +-- pndis :: [([[Edge]], NontDependencyInformation)] + pndis <- forM ndis $ \ndi -> do + ipend <- mapM (graphEdges . pdgmDepGraph) . ndimProds $ ndi + return (ipend, ndi) + knuth1' pndis + +-- | Helper function for |knuth1| which repeats the process until we are done +knuth1' :: [([[Edge]], NontDependencyInformationM s)] -> ST s () +knuth1' ndis = do -- Add edges from the production graphs to the nonterminal graph +-- ndis' :: [[Edge]] + ndis' <- mapM addProdNont ndis + -- List of all newly added edges +-- ntedge :: [Edge] + let pntedge = concat ndis' + -- Add backedges + --bedges <- addBackEdges ndis + -- All added nonterminal edges + let ntedge = pntedge -- ++ bedges + if null ntedge + -- When no new edges have been added we are done + then return () + else do -- Otherwise, the next step is to add edges from nonterminal to production graphs +-- ndis'' :: [[[Edge]]] + ndis'' <- mapM (\(_,x) -> addNontProd True (ntedge, x)) ndis + -- List of new states (production edges + dependency graphs) +-- nndis' :: [([[Edge]], NontDependencyInformation)] + nndis' <- zipWithM (\(_,ndi) me -> return (me, ndi)) ndis ndis'' + if any (not . null) ndis'' + -- We have added some edges, so continue the process + then knuth1' nndis' + -- No new edges added, we are done + else return () + +-- | Add pending edges from the production graphs to the nonterminal graph +-- and return the list of newly added nonterminal edges +addProdNont :: ([[Edge]], NontDependencyInformationM s) -> ST s [Edge] +addProdNont (pending, ndi) = do -- Unwrapping of the records + let nontDepGraph = ndimDepGraph ndi + let nontGraph = ndgmDepGraph nontDepGraph + -- nub the list because multiple productions can result in the same new edges + let possa = nub $ do (v1,v2) <- concat pending + -- Take only edges from syn.lhs to inh.lhs + guard $ isVertexAttr v1 + guard $ getAttrChildName v1 == _LHS + guard $ getAttrType v1 == Syn + guard $ isVertexAttr v2 + guard $ getAttrChildName v2 == _LHS + guard $ getAttrType v2 == Inh + -- Construct edge as it should be in nonterminal graph + let nv1 = setAttrChildName v1 (ndiNonterminal $ ndimOrig ndi) + let nv2 = setAttrChildName v2 (ndiNonterminal $ ndimOrig ndi) + return (nv1, nv2) + -- Edges that are not in the nonterminal graph yet + toadd <- filterM (\e -> return not `ap` graphContainsEdge nontGraph e) possa + -- Check whether new edges are to be added and return the added edges + when (not $ null toadd) $ do + graphInsertEdgesTRC nontGraph toadd + return () + return toadd + +-- | Add edges from the nonterminal graphs to the production graphs +-- and return the list of newly added production edges and the updated graph +addNontProd :: Bool -> ([Edge], NontDependencyInformationM s) -> ST s [[Edge]] +addNontProd trc (pending, ndi) = do -- Just call the helper function for each nonterminal + mapM (addNontProd' trc pending) (ndimProds ndi) + +-- | Helper function for |addNontProd| for a single production +addNontProd' :: Bool -> [Edge] -> ProdDependencyGraphM s -> ST s [Edge] +addNontProd' trc pend pdg = do -- Unwrapping of the records + prodGraph <- return $ pdgmDepGraph pdg + -- Construct all possible new edges + let possa = do (v1,v2) <- pend + -- Take a child of this nonterminal type + guard $ isVertexAttr v1 + guard $ isVertexAttr v2 + let tp = getAttrChildName v1 + (ch,chtp) <- pdgChildMap $ pdgmOrig pdg + guard $ tp == chtp + -- Construct edge as it should be in the production graph + let nv1 = setAttrChildName v1 ch + let nv2 = setAttrChildName v2 ch + return (nv1, nv2) + -- Edges that are not in the production graph yet + toadd <- filterM (\e -> return not `ap` graphContainsEdge prodGraph e) possa + -- Check whether new edges are to be added and return the result + if null toadd + then return [] + else do -- Insert all edges and return transitive edges that are added in this process + ret <- if trc + then graphInsertEdgesTRC prodGraph toadd + else do mapM_ (graphInsert prodGraph) toadd + return [] + -- Debug output + --mapM_ (\edge -> traceST $ "Adding production edge " ++ show edge) toadd + return ret + +-- | Add the "back edges" to the nonterminal graphs for creating a global ordering +addBackEdges :: [([[Edge]], NontDependencyInformationM s)] -> ST s [Edge] +addBackEdges ndis = do -- gather all backedges + lBackEdges <- forM ndis $ \(aedg,ndi) -> do + -- For every production + bs <- forM (zip aedg (ndimProds ndi)) $ \(edg,prod) -> do + -- Filter out the backedges + return $ do (v1,v2) <- edg + -- Backedges are from inh.ch to syn.ch + guard $ isVertexAttr v1 + guard $ getAttrChildName v1 /= _LHS + guard $ getAttrType v1 == Inh + guard $ isVertexAttr v2 + guard $ getAttrChildName v2 /= _LHS + guard $ getAttrType v2 == Syn + guard $ getAttrChildName v1 == getAttrChildName v2 + -- Find the correct child name + (ch,chtp) <- pdgChildMap $ pdgmOrig prod + let tp = getAttrChildName v1 + guard $ tp == ch + -- Construct the edge as it should be in the nonterminal graph + let nv1 = setAttrChildName v1 chtp + let nv2 = setAttrChildName v2 chtp + return (nv1, nv2) + return $ foldl' union [] bs + -- Concatenate all lists of backedges + let backedges = foldl' union [] lBackEdges + -- Add backedges to every nonterminal graph + ret <- forM ndis $ \(_,ndi) -> do + -- Find the backedges for this nonterminal + let nont = ndiNonterminal . ndimOrig $ ndi + let thisbe = filter ((==) nont . getAttrChildName . fst) backedges + -- Add them to the graph + graphInsertEdgesTRC (ndgmDepGraph . ndimDepGraph $ ndi) thisbe + return $ backedges ++ concat ret + + +-- | Add all resulting edges from a topsort on the nonterminal graph to the production graph +-- this will ignore edges that will make the graph cyclic +addTopSortEdges :: [Edge] -> ProdDependencyGraphM s -> ST s () +addTopSortEdges pend pdg = do -- Unwrapping of the records + prodGraph <- return $ pdgmDepGraph pdg + -- Construct all possible new edges + let possa = do (v1,v2) <- pend + -- Take a child of this nonterminal type + guard $ isVertexAttr v1 + guard $ isVertexAttr v2 + let tp = getAttrChildName v1 + (ch,chtp) <- pdgChildMap $ pdgmOrig pdg + guard $ tp == chtp + -- Construct edge as it should be in the production graph + let nv1 = setAttrChildName v1 ch + let nv2 = setAttrChildName v2 ch + return (nv1, nv2) + -- Edges that are not in the production graph yet + forM_ possa $ \(v1,v2) -> do e1 <- graphContainsEdge prodGraph (v1,v2) + e2 <- graphContainsEdge prodGraph (v2,v1) + when (not $ e1 || e2) $ do + graphInsertTRC prodGraph (v1,v2) + return () diff --git a/src/LOAG/AOAG.hs b/src/LOAG/AOAG.hs --- a/src/LOAG/AOAG.hs +++ b/src/LOAG/AOAG.hs @@ -1,282 +1,282 @@ -{-# LANGUAGE Rank2Types #-} - -module LOAG.AOAG where - -import LOAG.Common -import LOAG.Graphs -import LOAG.Rep - -import AbstractSyntax -import CommonTypes -import Control.Arrow ((&&&), (***)) -import Control.Monad (forM, forM_, MonadPlus(..), when, unless) -import Control.Monad.ST -import Control.Monad.Error (ErrorT(..)) -import Control.Monad.State (MonadState(..)) -import Data.Maybe (fromMaybe, catMaybes, fromJust, isNothing) -import Data.List (elemIndex, foldl', delete, (\\), insert, nub) -import Data.STRef -import Data.Tuple (swap) -import qualified Data.Set as S -import qualified Data.IntSet as IS -import qualified Data.IntMap as IM -import qualified Data.Map as M -import Data.Array.MArray -import qualified Data.Array as A -import Data.Array.ST -import ErrorMessages as Err -import Pretty -import UU.Scanner.Position - -data Settings = Settings - { -- current minimum ads size - prune_val :: Int - -- whether to minimize the number of fake dependencies - -- could be very costly - , min_ads :: Bool - } -default_settings = Settings 999 False - -type AOAG s a = ST s a - --- | Catch a type 3 cycle-error made by a given constructor --- | two alternatives are given to proceed -type ADS = [Edge] -type AOAGRes = Either Error LOAGRes --- | Calculate a total order if the semantics given --- originate from a linearly-ordered AG - -type2error,limiterror,aoagerror :: Error -type2error = Err.CustomError False noPos $ text "Type 2 cycle" -limiterror = Err.CustomError False noPos $ text "Limit reached" -aoagerror = Err.CustomError False noPos $ text "Not an LOAG/AOAG" - -schedule :: LOAGRep -> Grammar -> Ag -> [Edge] -> AOAGRes -schedule sem gram@(Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) - ag@(Ag bounds_s bounds_p de nts) ads - = runST $ aoag default_settings ads - where - -- get the maps from semantics and translate them to functions - nmp = (nmp_LOAGRep_LOAGRep sem) - ofld = (ofld_LOAGRep_LOAGRep sem) - genA = gen_LOAGRep_LOAGRep sem - inss = inss_LOAGRep_LOAGRep sem - - -- select candidates, using the edge that caused the cycle - -- from the list of intra-thread dependencies - -- (intra-visit dependencies without edges in ids) - candidates :: Edge -> Cycle -> [Edge] -> [Edge] - candidates _ c = foldr (\(f,t) acc -> - if f `IS.member` c &&t `IS.member` c - then (t,f):acc else acc) [] - -- | Move occurrence to its corresponding attribute - gen :: Vertex -> Vertex - gen v = genA A.! v - - genEdge :: Edge -> Edge - genEdge (f,t) = (gen f, gen t) - - -- | Decide for a given production edge whether the vertices - -- belong to the same field - siblings :: Edge -> Bool - siblings (f, t) = ofld A.! f == ofld A.! t - - -- | Given an nonterminal-edge, instantiate it - -- assumes that the occurrences of fields are added in the same order - instEdge :: Edge -> [Edge] - instEdge (f, t) = zip (inss A.! f) (inss A.! t) - - aoag :: Settings -> [Edge] -> AOAG s AOAGRes - aoag cfg init_ads = run - where - run :: AOAG s AOAGRes - run = induced ads >>= detect - - detect (Left err) = return $ Left err - detect (Right (dp,idp,ids@(idsf,idst))) = do - -- Attribute -> TimeSlot - schedA <- mapArray (const Nothing) idsf - -- map TimeSlot -> [Attribute] - schedS <- newSTRef $ - foldr (\(Nonterminal nt _ _ _ _) -> M.insert (getName nt) - (IM.singleton 1 [])) M.empty dats - fr_ids <- freeze_graph ids - threads <- completing fr_ids (schedA, schedS) nts - let (ivd, comp) = fetchEdges fr_ids threads nts - eRoC <- m_edp dp init_ads ivd comp (schedA, schedS) - case eRoC of - Left res -> return $ Right res - Right (e,c,T3 cs) -> find_ads dp idp ids (schedA, schedS) e c cs - - find_ads :: Graph s -> Graph s -> Graph s -> SchedRef s -> - Edge -> Cycle -> [Edge] -> AOAG s AOAGRes - find_ads dp idp ids sched e cycle comp = do - pruner <- newSTRef 999 - explore dp idp ids sched init_ads pruner e cycle comp - - explore :: Graph s -> Graph s -> Graph s -> SchedRef s -> - [Edge] -> STRef s Int -> Edge -> Cycle -> [Edge] -> - AOAG s AOAGRes - explore dp idp ids sched@(schedA, schedS) ads pruner e c comp = - explore' dp idp ids sched ads (candidates e c comp) pruner - where - explore' :: Graph s -> Graph s -> Graph s -> SchedRef s -> - [Edge] -> [Edge] -> STRef s Int -> - AOAG s AOAGRes - explore' _ _ _ _ _ [] _ = return $ Left aoagerror - explore' dp idp ids sched@(schedA,schedS) ads (fd:cs) pruner = do - p_val <- readSTRef pruner - if length ads >= p_val -1 - then return $ Left limiterror - else do - idpf_clone <- mapArray id (fst idp) - idpt_clone <- mapArray id (snd idp) - let idp_c = (idpf_clone, idpt_clone) - idsf_clone <- mapArray id (fst ids) - idst_clone <- mapArray id (snd ids) - let ids_c = (idsf_clone, idst_clone) - schedA_c <- mapArray id schedA - schedS_v <- readSTRef schedS - schedS_c <- newSTRef schedS_v - let sched_c = (schedA_c, schedS_c) - - let runM = reschedule dp idp ids sched - (fd:ads) fd pruner - let backtrack = explore' dp idp_c ids_c sched_c ads cs - pruner - maoag <- runM - case maoag of - Left _ -> backtrack - Right (tdp1,inf1,ads1) -> - if LOAG.AOAG.min_ads cfg - then do - writeSTRef pruner (length ads1) - maoag' <- backtrack - case maoag' of - Right (tdp2,inf2,ads2) - -> return $ Right (tdp2,inf2,ads2) - otherwise -> return $ Right (tdp1,inf1,ads1) - else return $ Right (tdp1,inf1,ads1) - - -- step 1, 2 and 3 - induced :: [Edge] -> AOAG s (Either Error (Graph s, Graph s, Graph s)) - induced ads = do - dpf <- newArray bounds_p IS.empty - dpt <- newArray bounds_p IS.empty - idpf <- newArray bounds_p IS.empty - idpt <- newArray bounds_p IS.empty - idsf <- newArray bounds_s IS.empty - idst <- newArray bounds_s IS.empty - let ids = (idsf,idst) - let idp = (idpf,idpt) - let dp = (dpf ,dpt) - inducing dp idp ids (de ++ ads) - - inducing :: Graph s -> Graph s -> Graph s -> [Edge] - -> AOAG s (Either Error (Graph s, Graph s, Graph s)) - inducing dp idp ids es = do - res <- adds (addD dp idp ids) [] es - case res of - Left _ -> return $ Left $ type2error - Right _ -> return $ Right (dp, idp, ids) - addD :: Graph s -> Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge]) - addD dp' idp' ids' e = do - resd <- e `insErt` dp' - resdp <- e `inserT` idp' - case resdp of - Right es -> adds (addN idp' ids') [] (e:es) - Left c -> return $ Left $ type2error - - addI :: Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge]) - addI idp' ids' e = do - exists <- member e idp' - if not exists then do - res <- e `inserT` idp' - case res of - Right es -> adds (addN idp' ids') [] es - Left c -> return $ Left $ type2error - else return $ Right [] - - adds f acc [] = return $ Right acc - adds f acc (e:es) = do - mes <- f e - case mes of - Left err -> return $ Left err - Right news -> adds f (acc++news) es - - addN :: Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge]) - addN idp' ids' e = do - if (siblings e) then do - let s_edge = genEdge e - exists <- member s_edge ids' - if not exists then do - _ <- inserT s_edge ids' - let es = instEdge s_edge - addedEx <- adds (addI idp' ids') [] es - case addedEx of - Right news -> return $ Right (s_edge : news) - Left err -> return $ Left err - else return $ Right [] - else return $ Right [] - - - -- step 6, 7 - m_edp :: Graph s -> [Edge] -> [Edge] -> [Edge] -> SchedRef s -> - AOAG s (Either LOAGRes (Edge,Cycle,CType)) - m_edp (dpf, dpt) ads ivd comp sched = do - edpf <- mapArray id dpf - edpt <- mapArray id dpt - mc <- addEDs (edpf,edpt) (concatMap instEdge ivd) - case mc of - Just (e, c) -> return $ Right (e,c,T3 $ concatMap instEdge comp) - Nothing -> do - tdp <- freeze edpt - infs <- readSTRef (snd sched) - return $ Left (Just tdp,infs,ads) - - reschedule :: Graph s -> Graph s -> Graph s -> SchedRef s -> - [Edge] -> Edge -> STRef s Int - -> AOAG s AOAGRes - reschedule dp idp ids sched@(_,threadRef) ads e pruner = do - extra <- addN idp ids e - case extra of - Left err -> return $ Left err - Right extra -> do - forM_ extra $ swap_ivd ids sched - fr_ids <- freeze_graph ids - threads <- readSTRef threadRef - let (ivd, comp) = fetchEdges fr_ids threads nts - eRoC <- m_edp dp ads ivd comp sched - case eRoC of - Left res -> return $ Right res - Right (e,c,(T3 cs)) -> explore dp idp ids sched ads pruner e c cs - where - swap_ivd :: Graph s -> SchedRef s -> Edge -> AOAG s () - swap_ivd ids@(idsf, idst) sr@(schedA, schedS) (f,t) = do - --the edge should point from higher to lower timeslot - assigned <- freeze schedA - let oldf = maybe (error "unassigned f") id $ assigned A.! f - oldt = maybe (error "unassigned t") id $ assigned A.! t - dirf = snd $ alab $ nmp M.! f - dirt = snd $ alab $ nmp M.! t - newf | oldf < oldt = oldt + (if dirf /= dirt then 1 else 0) - | otherwise = oldf - nt = show $ typeOf $ nmp M.! f - - -- the edge was pointing in wrong direction so we moved - -- the attribute to a new interaction, now some of its - -- predecessors/ancestors might need to be moved too - unless (oldf == newf) $ do - writeArray schedA f (Just newf) - modifySTRef schedS - (M.adjust (IM.update (Just . delete f) oldf) nt) - modifySTRef schedS - (M.adjust(IM.alter(Just. maybe [f] (insert f))newf)nt) - predsf <- readArray idst f - succsf <- readArray idsf f - let rest = (map (flip (,) f) $ IS.toList predsf) ++ - (map ((,) f) $ IS.toList succsf) - in mapM_ (swap_ivd ids sr) rest - - - +{-# LANGUAGE Rank2Types #-} + +module LOAG.AOAG where + +import LOAG.Common +import LOAG.Graphs +import LOAG.Rep + +import AbstractSyntax +import CommonTypes +import Control.Arrow ((&&&), (***)) +import Control.Monad (forM, forM_, MonadPlus(..), when, unless) +import Control.Monad.ST +import Control.Monad.Error (ErrorT(..)) +import Control.Monad.State (MonadState(..)) +import Data.Maybe (fromMaybe, catMaybes, fromJust, isNothing) +import Data.List (elemIndex, foldl', delete, (\\), insert, nub) +import Data.STRef +import Data.Tuple (swap) +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.IntMap as IM +import qualified Data.Map as M +import Data.Array.MArray +import qualified Data.Array as A +import Data.Array.ST +import ErrorMessages as Err +import Pretty +import UU.Scanner.Position + +data Settings = Settings + { -- current minimum ads size + prune_val :: Int + -- whether to minimize the number of fake dependencies + -- could be very costly + , min_ads :: Bool + } +default_settings = Settings 999 False + +type AOAG s a = ST s a + +-- | Catch a type 3 cycle-error made by a given constructor +-- | two alternatives are given to proceed +type ADS = [Edge] +type AOAGRes = Either Error LOAGRes +-- | Calculate a total order if the semantics given +-- originate from a linearly-ordered AG + +type2error,limiterror,aoagerror :: Error +type2error = Err.CustomError False noPos $ text "Type 2 cycle" +limiterror = Err.CustomError False noPos $ text "Limit reached" +aoagerror = Err.CustomError False noPos $ text "Not an LOAG/AOAG" + +schedule :: LOAGRep -> Grammar -> Ag -> [Edge] -> AOAGRes +schedule sem gram@(Grammar _ _ _ _ dats _ _ _ _ _ _ _ _ _) + ag@(Ag bounds_s bounds_p de nts) ads + = runST $ aoag default_settings ads + where + -- get the maps from semantics and translate them to functions + nmp = (nmp_LOAGRep_LOAGRep sem) + ofld = (ofld_LOAGRep_LOAGRep sem) + genA = gen_LOAGRep_LOAGRep sem + inss = inss_LOAGRep_LOAGRep sem + + -- select candidates, using the edge that caused the cycle + -- from the list of intra-thread dependencies + -- (intra-visit dependencies without edges in ids) + candidates :: Edge -> Cycle -> [Edge] -> [Edge] + candidates _ c = foldr (\(f,t) acc -> + if f `IS.member` c &&t `IS.member` c + then (t,f):acc else acc) [] + -- | Move occurrence to its corresponding attribute + gen :: Vertex -> Vertex + gen v = genA A.! v + + genEdge :: Edge -> Edge + genEdge (f,t) = (gen f, gen t) + + -- | Decide for a given production edge whether the vertices + -- belong to the same field + siblings :: Edge -> Bool + siblings (f, t) = ofld A.! f == ofld A.! t + + -- | Given an nonterminal-edge, instantiate it + -- assumes that the occurrences of fields are added in the same order + instEdge :: Edge -> [Edge] + instEdge (f, t) = zip (inss A.! f) (inss A.! t) + + aoag :: Settings -> [Edge] -> AOAG s AOAGRes + aoag cfg init_ads = run + where + run :: AOAG s AOAGRes + run = induced ads >>= detect + + detect (Left err) = return $ Left err + detect (Right (dp,idp,ids@(idsf,idst))) = do + -- Attribute -> TimeSlot + schedA <- mapArray (const Nothing) idsf + -- map TimeSlot -> [Attribute] + schedS <- newSTRef $ + foldr (\(Nonterminal nt _ _ _ _) -> M.insert (getName nt) + (IM.singleton 1 [])) M.empty dats + fr_ids <- freeze_graph ids + threads <- completing fr_ids (schedA, schedS) nts + let (ivd, comp) = fetchEdges fr_ids threads nts + eRoC <- m_edp dp init_ads ivd comp (schedA, schedS) + case eRoC of + Left res -> return $ Right res + Right (e,c,T3 cs) -> find_ads dp idp ids (schedA, schedS) e c cs + + find_ads :: Graph s -> Graph s -> Graph s -> SchedRef s -> + Edge -> Cycle -> [Edge] -> AOAG s AOAGRes + find_ads dp idp ids sched e cycle comp = do + pruner <- newSTRef 999 + explore dp idp ids sched init_ads pruner e cycle comp + + explore :: Graph s -> Graph s -> Graph s -> SchedRef s -> + [Edge] -> STRef s Int -> Edge -> Cycle -> [Edge] -> + AOAG s AOAGRes + explore dp idp ids sched@(schedA, schedS) ads pruner e c comp = + explore' dp idp ids sched ads (candidates e c comp) pruner + where + explore' :: Graph s -> Graph s -> Graph s -> SchedRef s -> + [Edge] -> [Edge] -> STRef s Int -> + AOAG s AOAGRes + explore' _ _ _ _ _ [] _ = return $ Left aoagerror + explore' dp idp ids sched@(schedA,schedS) ads (fd:cs) pruner = do + p_val <- readSTRef pruner + if length ads >= p_val -1 + then return $ Left limiterror + else do + idpf_clone <- mapArray id (fst idp) + idpt_clone <- mapArray id (snd idp) + let idp_c = (idpf_clone, idpt_clone) + idsf_clone <- mapArray id (fst ids) + idst_clone <- mapArray id (snd ids) + let ids_c = (idsf_clone, idst_clone) + schedA_c <- mapArray id schedA + schedS_v <- readSTRef schedS + schedS_c <- newSTRef schedS_v + let sched_c = (schedA_c, schedS_c) + + let runM = reschedule dp idp ids sched + (fd:ads) fd pruner + let backtrack = explore' dp idp_c ids_c sched_c ads cs + pruner + maoag <- runM + case maoag of + Left _ -> backtrack + Right (tdp1,inf1,ads1) -> + if LOAG.AOAG.min_ads cfg + then do + writeSTRef pruner (length ads1) + maoag' <- backtrack + case maoag' of + Right (tdp2,inf2,ads2) + -> return $ Right (tdp2,inf2,ads2) + otherwise -> return $ Right (tdp1,inf1,ads1) + else return $ Right (tdp1,inf1,ads1) + + -- step 1, 2 and 3 + induced :: [Edge] -> AOAG s (Either Error (Graph s, Graph s, Graph s)) + induced ads = do + dpf <- newArray bounds_p IS.empty + dpt <- newArray bounds_p IS.empty + idpf <- newArray bounds_p IS.empty + idpt <- newArray bounds_p IS.empty + idsf <- newArray bounds_s IS.empty + idst <- newArray bounds_s IS.empty + let ids = (idsf,idst) + let idp = (idpf,idpt) + let dp = (dpf ,dpt) + inducing dp idp ids (de ++ ads) + + inducing :: Graph s -> Graph s -> Graph s -> [Edge] + -> AOAG s (Either Error (Graph s, Graph s, Graph s)) + inducing dp idp ids es = do + res <- adds (addD dp idp ids) [] es + case res of + Left _ -> return $ Left $ type2error + Right _ -> return $ Right (dp, idp, ids) + addD :: Graph s -> Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge]) + addD dp' idp' ids' e = do + resd <- e `insErt` dp' + resdp <- e `inserT` idp' + case resdp of + Right es -> adds (addN idp' ids') [] (e:es) + Left c -> return $ Left $ type2error + + addI :: Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge]) + addI idp' ids' e = do + exists <- member e idp' + if not exists then do + res <- e `inserT` idp' + case res of + Right es -> adds (addN idp' ids') [] es + Left c -> return $ Left $ type2error + else return $ Right [] + + adds f acc [] = return $ Right acc + adds f acc (e:es) = do + mes <- f e + case mes of + Left err -> return $ Left err + Right news -> adds f (acc++news) es + + addN :: Graph s -> Graph s -> Edge -> AOAG s (Either Error [Edge]) + addN idp' ids' e = do + if (siblings e) then do + let s_edge = genEdge e + exists <- member s_edge ids' + if not exists then do + _ <- inserT s_edge ids' + let es = instEdge s_edge + addedEx <- adds (addI idp' ids') [] es + case addedEx of + Right news -> return $ Right (s_edge : news) + Left err -> return $ Left err + else return $ Right [] + else return $ Right [] + + + -- step 6, 7 + m_edp :: Graph s -> [Edge] -> [Edge] -> [Edge] -> SchedRef s -> + AOAG s (Either LOAGRes (Edge,Cycle,CType)) + m_edp (dpf, dpt) ads ivd comp sched = do + edpf <- mapArray id dpf + edpt <- mapArray id dpt + mc <- addEDs (edpf,edpt) (concatMap instEdge ivd) + case mc of + Just (e, c) -> return $ Right (e,c,T3 $ concatMap instEdge comp) + Nothing -> do + tdp <- freeze edpt + infs <- readSTRef (snd sched) + return $ Left (Just tdp,infs,ads) + + reschedule :: Graph s -> Graph s -> Graph s -> SchedRef s -> + [Edge] -> Edge -> STRef s Int + -> AOAG s AOAGRes + reschedule dp idp ids sched@(_,threadRef) ads e pruner = do + extra <- addN idp ids e + case extra of + Left err -> return $ Left err + Right extra -> do + forM_ extra $ swap_ivd ids sched + fr_ids <- freeze_graph ids + threads <- readSTRef threadRef + let (ivd, comp) = fetchEdges fr_ids threads nts + eRoC <- m_edp dp ads ivd comp sched + case eRoC of + Left res -> return $ Right res + Right (e,c,(T3 cs)) -> explore dp idp ids sched ads pruner e c cs + where + swap_ivd :: Graph s -> SchedRef s -> Edge -> AOAG s () + swap_ivd ids@(idsf, idst) sr@(schedA, schedS) (f,t) = do + --the edge should point from higher to lower timeslot + assigned <- freeze schedA + let oldf = maybe (error "unassigned f") id $ assigned A.! f + oldt = maybe (error "unassigned t") id $ assigned A.! t + dirf = snd $ alab $ nmp M.! f + dirt = snd $ alab $ nmp M.! t + newf | oldf < oldt = oldt + (if dirf /= dirt then 1 else 0) + | otherwise = oldf + nt = show $ typeOf $ nmp M.! f + + -- the edge was pointing in wrong direction so we moved + -- the attribute to a new interaction, now some of its + -- predecessors/ancestors might need to be moved too + unless (oldf == newf) $ do + writeArray schedA f (Just newf) + modifySTRef schedS + (M.adjust (IM.update (Just . delete f) oldf) nt) + modifySTRef schedS + (M.adjust(IM.alter(Just. maybe [f] (insert f))newf)nt) + predsf <- readArray idst f + succsf <- readArray idsf f + let rest = (map (flip (,) f) $ IS.toList predsf) ++ + (map ((,) f) $ IS.toList succsf) + in mapM_ (swap_ivd ids sr) rest + + + diff --git a/src/LOAG/Chordal.hs b/src/LOAG/Chordal.hs --- a/src/LOAG/Chordal.hs +++ b/src/LOAG/Chordal.hs @@ -1,271 +1,271 @@ -{-# LANGUAGE CPP #-} - -module LOAG.Chordal where - -#ifdef WITH_LOAG - -import LOAG.Common -import LOAG.Graphs -import LOAG.Optimise -import LOAG.Solver.MiniSat -import Options - -import Control.Monad (unless, forM, when, foldM) -import Control.Monad.ST -import qualified Data.Array as A -import Data.Array.IO -import Data.Array.ST as ST -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as M -import Data.Maybe (isNothing, catMaybes) -import qualified Data.Set as S -import Data.STRef - -type Neigh = (Vertex, EdgeType) -data EdgeType = Sib MyVar -- Edge between siblings - | Any MyVar -- Unknown - | NSib MyVar -- Edge between non-siblings - deriving (Show) - -extract (Sib l) = l -extract (Any l) = l -extract (NSib l)= l - -neg :: EdgeType -> EdgeType -neg (Sib p) = Sib $ varnot p -neg (NSib p) = NSib $ varnot p -neg (Any p) = Any $ varnot p - - -type NtGraph = IM.IntMap [(Vertex,MyVar)] -type ToChordal = IM.IntMap [Neigh] -type SatEdge = (Vertex, Neigh) - -addClauses :: Sat -> [[EdgeType]] -> IO () -addClauses sat = mapM_ (addClause sat . map extract) - -toChordal :: [(Edge,EdgeType)] -> IO ToChordal -toChordal es = - let edges = concatMap (\((a,b),c) -> [(a,[(b,c)]),(b,[(a,neg c)])]) es - in return $ IM.fromListWith (++) edges - -toNtGraph :: [(Edge,MyVar)] -> IO NtGraph -toNtGraph es = - let edges = concatMap (\((a,b),c) -> [(a,[(b,c)]),(b,[(a,varnot c)])]) es - in return $ IM.fromListWith (++) edges - - -remove :: Vertex -> [Neigh] -> ToChordal -> ToChordal -remove v ns g = foldr (IM.adjust remN . fst) (IM.delete v g) ns - where remN ns = filter ((/= v).fst) ns - -adds :: ToChordal -> [SatEdge] -> ToChordal -adds g = foldl add g - -add :: ToChordal -> SatEdge -> ToChordal -add g (v,n@(v2,c)) = IM.adjust (n:) v - $ IM.adjust ((v,neg c):) v2 g - -removeNt :: Vertex -> [(Vertex,MyVar)] -> NtGraph -> NtGraph -removeNt v ns g = foldr (IM.adjust remN . fst) (IM.delete v g) ns - where remN ns = filter ((/= v).fst) ns - -addsNt g = foldl addNt g - -addNt g (v,n@(v2,c)) = IM.adjust (n:) v - $ IM.adjust ((v,varnot c):) v2 g - -scheduleLOAG :: Ag -> (String -> IO ()) -> Options -> IO LOAGRes -scheduleLOAG ag@(Ag nbounds pbounds dps nts) putStrLn opts = do - let optim | minvisits opts = [MinVisits] -- todo: allow specification of more optimisations - | otherwise = [] - putStrLn "--- Starting ---" - sat <- newSolvable - varMap <- noNtCycles sat nts putStrLn - noPrCycles sat prs varMap putStrLn - (v,p) <- satValues sat - putStrLn $ "nr. of variables: " ++ show v - putStrLn $ "nr. of clauses: " ++ show p - putStrLn "--- Solving ---" - b <- satsolve sat [] - if not b then error "Not LOAG" - else do putStrLn "--- Constructing Interfaces ---" - (ids,edp,interfaces) <- loagRes sat varMap dps - let oldct = getVisCount nts interfaces - when (minvisits opts) $ - putStrLn "--- Minimising #Visit" - optimise sat varMap optim nbounds nts interfaces - (ids',edp',interfaces') <- loagRes sat varMap dps - let visC@newct = getVisCount nts interfaces' - when (minvisits opts) $ do - putStrLn ("--- #Visits (max,sum,avg) " ++(show oldct) - ++" --> " ++(show newct)) - putStrLn "--- Code Generation ---" - return (Just edp',interfaces',[]) - where loagRes sat varMap dps = do - (ids,edp) <- mkGraphs sat varMap dps - interfaces <- mkInterfaces ids - return (ids,edp,interfaces) - prs = [ p | (Nt _ _ _ _ _ ps) <- nts, p <- ps] - mkInterfaces ids = return $ runST $ do - schedA <- newArray nbounds Nothing - schedS <- newSTRef $ foldr (\(Nt nt _ _ _ _ _) -> - M.insert nt (IM.singleton 1 [])) - M.empty nts - completing ids (schedA, schedS) nts - - mkGraphs :: Sat -> M.Map Edge MyVar -> [Edge] -> - IO (FrGraph,TDPRes) - mkGraphs sat varMap dps = do - idsf <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices) - idst <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices) - edp <- newArray pbounds IS.empty :: IO (IOArray Vertex Vertices) - let (ids) = (idsf,idst) - sequence_ [ do v <- value sat pred - case v of - Nothing -> error "no val" - Just True -> addEdges (i,s) (zip ios sos) ids edp - Just False-> addEdges (s,i) (zip sos ios) ids edp - | Nt _ _ _ inhs outs _ <- nts - , (i,ios,_) <- inhs - , (s,sos,_) <- outs - , let pred = varMap M.! (i,s) - ] - forM dps $ \(f,t) -> do - modifyArray edp t (f `IS.insert`) - f_idsf <- freeze idsf - f_idst <- freeze idst - f_edp <- freeze edp - return ((f_idsf,f_idst),f_edp) - where addEdges - :: (Vertex, Vertex) - -> [(Vertex, Vertex)] - -> (IOArray Vertex Vertices, IOArray Vertex Vertices) - -> IOArray Vertex Vertices - -> IO [()] - addEdges (f,t) es (idsf,idst) edp = do - modifyArray idsf f (t `IS.insert`) - modifyArray idst t (f `IS.insert`) - forM es $ \(f,t) -> do --edp does not reflect flow - modifyArray edp t (f `IS.insert`) - -noCyclesNt :: Sat -> NtGraph -> IO () -noCyclesNt sat g | IM.null g = return () - | otherwise = do - news <- sequence [ noTriangleNt sat g p q | (p,q) <- pairs neighs] - let g' = addsNt (removeNt node neighs g) (concat news) - noCyclesNt sat g' - where - node = snd $ minimum [ (length xs, a) | (a,xs) <- IM.toList g ] - Just neighs = IM.lookup node g - -noTriangleNt :: Sat -> NtGraph -> (Vertex, MyVar) -> - (Vertex, MyVar) -> IO [(Vertex,(Vertex,MyVar))] -noTriangleNt sat g e1@(t1,c1) e2@(t2,c2) = - case IM.lookup t1 g of - Just ns -> - case [ c | (t2',c) <- ns, t2' == t2 ] of - [] -> do c3 <- newLit sat - ruleOut c1 c2 c3 - return [(t1,(t2,c3))] - [c3] -> ruleOut c1 c2 c3 >> return [] - _ -> error "multiple edges between two nodes" - Nothing -> error "pointer outside of graph" - where - ruleOut ea eb ab= do addClause sat [ea, ab, varnot eb] - addClause sat [varnot ea,varnot ab,eb] - -noCyclesPr :: Sat -> ToChordal -> IO () -noCyclesPr sat g | IM.null g = return () - | otherwise = do - news <- sequence [ noTriangle sat g p q | (p,q) <- validPairs neighs] - let g' = adds (remove node neighs g) (concat news) - noCyclesPr sat g' - where - node = snd $ minimum [ (weight xs, a) - | (a,xs) <- IM.toList g ] - Just neighs = IM.lookup node g - validPairs ns = [ (p,q) | p <- sibs, q <- nsibs ] ++ - [ (p,q) | p <- nsibs, q <- anys ] ++ - [ (p,q) | p <- sibs, q <- anys ] - ++ (pairs anys) - where sibs = [ n | n@(_,Sib _) <- ns ] - nsibs= [ n | n@(_,NSib _) <- ns ] - anys = [ n | n@(_,Any _) <- ns ] - weight :: [Neigh] -> Int - weight xs = ss*3 * (ds + cs) + (ds + cs)^2 - where - ss = length [ x | x@(_,Sib _) <- xs ] - ds = length [ x | x@(_,NSib _) <- xs ] - cs = length [ x | x@(_,Any _) <- xs ] - -noTriangle :: Sat -> ToChordal -> Neigh -> Neigh -> IO [SatEdge] -noTriangle sat g e1@(t1,c1) e2@(t2,c2) = - case IM.lookup t1 g of - Just ns -> - case [ c | (t2',c) <- ns, t2' == t2 ] of - [] -> do p <- newLit sat - ruleOut c1 c2 (Any p) - return [(t1,(t2,(Any p)))] - [c3] -> ruleOut c1 c2 c3 >> return [] - _ -> error "multiple edges between two nodes" - Nothing -> error "pointer outside of graph" - where ruleOut ea eb ab= addClauses sat [[ea, ab, neg eb],[neg ea,neg ab,eb]] -noNtCycles :: Sat -> [Nt] -> (String -> IO ()) -> IO VarMap -noNtCycles sat tps putStrLn = do - putStrLn "--- Non-Terminals ---" - maps <- mapM forNt tps - return $ M.unions maps - where -- at non-terminal level, all cycles are between siblings - -- that is why we force all the edges to be the same - -- (not filtered by validPairs) - forNt tp@(Nt tid dpf dpt inhs syns _) = do - vars <- satValues sat - putStrLn ("nt : " ++ tid ++ " ... " ++ - show vars ++ " ...") - when (not $ S.null $ S.fromList dpf `S.intersection` - S.fromList (map (\(a,b) -> (b,a)) dpt)) $ - error "Type 2 cycle of length 2" - ass <- sequence $ - [ return ((i,s),VarTrue) | ((i,s)) <- dpf ]++ - [ return ((i,s),VarFalse)| ((s,i)) <- dpt ] - let assM = M.fromList ass - mvars<- sequence - [ if new then do - p <- newLit sat - return $ Just ((i,s),p) else return Nothing - | (i,_,_) <- inhs - , (s,_,_) <- syns - , let mmv = maybe (M.lookup (s,i) assM) Just - (M.lookup (i,s) assM) - new = isNothing mmv ] - let vars = ass ++ catMaybes mvars - g <- toNtGraph vars - noCyclesNt sat g - return $ M.fromList vars - - -noPrCycles :: Sat -> [Pr] -> VarMap -> (String -> IO ()) -> IO () -noPrCycles sat prods varMap putStrLn = do - putStrLn "--- Productions ---" - mapM_ forProd prods - where forProd (Pr prod es ses fs) | length fs ==1 = return () --taken care of - | otherwise = do - vars <- satValues sat - putStrLn ("prod: " ++ show prod ++ " ... " ++ - show vars ++ " ...") - g <- toChordal (sibs ++ dps) - noCyclesPr sat g - where sibs= [ ((f,t),Sib c) | (e@(f,t),ge,_) <- ses - , let c = case M.lookup ge varMap of - Just p -> p - Nothing -> error "no var found"] - dps = [ (e,NSib VarTrue) | e <- es ] - - -#else - -scheduleLOAG = error "You need to install uuagc with the -fwith-loag flag in order to use the --loag option." - -#endif +{-# LANGUAGE CPP #-} + +module LOAG.Chordal where + +#ifdef WITH_LOAG + +import LOAG.Common +import LOAG.Graphs +import LOAG.Optimise +import LOAG.Solver.MiniSat +import Options + +import Control.Monad (unless, forM, when, foldM) +import Control.Monad.ST +import qualified Data.Array as A +import Data.Array.IO +import Data.Array.ST as ST +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as M +import Data.Maybe (isNothing, catMaybes) +import qualified Data.Set as S +import Data.STRef + +type Neigh = (Vertex, EdgeType) +data EdgeType = Sib MyVar -- Edge between siblings + | Any MyVar -- Unknown + | NSib MyVar -- Edge between non-siblings + deriving (Show) + +extract (Sib l) = l +extract (Any l) = l +extract (NSib l)= l + +neg :: EdgeType -> EdgeType +neg (Sib p) = Sib $ varnot p +neg (NSib p) = NSib $ varnot p +neg (Any p) = Any $ varnot p + + +type NtGraph = IM.IntMap [(Vertex,MyVar)] +type ToChordal = IM.IntMap [Neigh] +type SatEdge = (Vertex, Neigh) + +addClauses :: Sat -> [[EdgeType]] -> IO () +addClauses sat = mapM_ (addClause sat . map extract) + +toChordal :: [(Edge,EdgeType)] -> IO ToChordal +toChordal es = + let edges = concatMap (\((a,b),c) -> [(a,[(b,c)]),(b,[(a,neg c)])]) es + in return $ IM.fromListWith (++) edges + +toNtGraph :: [(Edge,MyVar)] -> IO NtGraph +toNtGraph es = + let edges = concatMap (\((a,b),c) -> [(a,[(b,c)]),(b,[(a,varnot c)])]) es + in return $ IM.fromListWith (++) edges + + +remove :: Vertex -> [Neigh] -> ToChordal -> ToChordal +remove v ns g = foldr (IM.adjust remN . fst) (IM.delete v g) ns + where remN ns = filter ((/= v).fst) ns + +adds :: ToChordal -> [SatEdge] -> ToChordal +adds g = foldl add g + +add :: ToChordal -> SatEdge -> ToChordal +add g (v,n@(v2,c)) = IM.adjust (n:) v + $ IM.adjust ((v,neg c):) v2 g + +removeNt :: Vertex -> [(Vertex,MyVar)] -> NtGraph -> NtGraph +removeNt v ns g = foldr (IM.adjust remN . fst) (IM.delete v g) ns + where remN ns = filter ((/= v).fst) ns + +addsNt g = foldl addNt g + +addNt g (v,n@(v2,c)) = IM.adjust (n:) v + $ IM.adjust ((v,varnot c):) v2 g + +scheduleLOAG :: Ag -> (String -> IO ()) -> Options -> IO LOAGRes +scheduleLOAG ag@(Ag nbounds pbounds dps nts) putStrLn opts = do + let optim | minvisits opts = [MinVisits] -- todo: allow specification of more optimisations + | otherwise = [] + putStrLn "--- Starting ---" + sat <- newSolvable + varMap <- noNtCycles sat nts putStrLn + noPrCycles sat prs varMap putStrLn + (v,p) <- satValues sat + putStrLn $ "nr. of variables: " ++ show v + putStrLn $ "nr. of clauses: " ++ show p + putStrLn "--- Solving ---" + b <- satsolve sat [] + if not b then error "Not LOAG" + else do putStrLn "--- Constructing Interfaces ---" + (ids,edp,interfaces) <- loagRes sat varMap dps + let oldct = getVisCount nts interfaces + when (minvisits opts) $ + putStrLn "--- Minimising #Visit" + optimise sat varMap optim nbounds nts interfaces + (ids',edp',interfaces') <- loagRes sat varMap dps + let visC@newct = getVisCount nts interfaces' + when (minvisits opts) $ do + putStrLn ("--- #Visits (max,sum,avg) " ++(show oldct) + ++" --> " ++(show newct)) + putStrLn "--- Code Generation ---" + return (Just edp',interfaces',[]) + where loagRes sat varMap dps = do + (ids,edp) <- mkGraphs sat varMap dps + interfaces <- mkInterfaces ids + return (ids,edp,interfaces) + prs = [ p | (Nt _ _ _ _ _ ps) <- nts, p <- ps] + mkInterfaces ids = return $ runST $ do + schedA <- newArray nbounds Nothing + schedS <- newSTRef $ foldr (\(Nt nt _ _ _ _ _) -> + M.insert nt (IM.singleton 1 [])) + M.empty nts + completing ids (schedA, schedS) nts + + mkGraphs :: Sat -> M.Map Edge MyVar -> [Edge] -> + IO (FrGraph,TDPRes) + mkGraphs sat varMap dps = do + idsf <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices) + idst <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices) + edp <- newArray pbounds IS.empty :: IO (IOArray Vertex Vertices) + let (ids) = (idsf,idst) + sequence_ [ do v <- value sat pred + case v of + Nothing -> error "no val" + Just True -> addEdges (i,s) (zip ios sos) ids edp + Just False-> addEdges (s,i) (zip sos ios) ids edp + | Nt _ _ _ inhs outs _ <- nts + , (i,ios,_) <- inhs + , (s,sos,_) <- outs + , let pred = varMap M.! (i,s) + ] + forM dps $ \(f,t) -> do + modifyArray edp t (f `IS.insert`) + f_idsf <- freeze idsf + f_idst <- freeze idst + f_edp <- freeze edp + return ((f_idsf,f_idst),f_edp) + where addEdges + :: (Vertex, Vertex) + -> [(Vertex, Vertex)] + -> (IOArray Vertex Vertices, IOArray Vertex Vertices) + -> IOArray Vertex Vertices + -> IO [()] + addEdges (f,t) es (idsf,idst) edp = do + modifyArray idsf f (t `IS.insert`) + modifyArray idst t (f `IS.insert`) + forM es $ \(f,t) -> do --edp does not reflect flow + modifyArray edp t (f `IS.insert`) + +noCyclesNt :: Sat -> NtGraph -> IO () +noCyclesNt sat g | IM.null g = return () + | otherwise = do + news <- sequence [ noTriangleNt sat g p q | (p,q) <- pairs neighs] + let g' = addsNt (removeNt node neighs g) (concat news) + noCyclesNt sat g' + where + node = snd $ minimum [ (length xs, a) | (a,xs) <- IM.toList g ] + Just neighs = IM.lookup node g + +noTriangleNt :: Sat -> NtGraph -> (Vertex, MyVar) -> + (Vertex, MyVar) -> IO [(Vertex,(Vertex,MyVar))] +noTriangleNt sat g e1@(t1,c1) e2@(t2,c2) = + case IM.lookup t1 g of + Just ns -> + case [ c | (t2',c) <- ns, t2' == t2 ] of + [] -> do c3 <- newLit sat + ruleOut c1 c2 c3 + return [(t1,(t2,c3))] + [c3] -> ruleOut c1 c2 c3 >> return [] + _ -> error "multiple edges between two nodes" + Nothing -> error "pointer outside of graph" + where + ruleOut ea eb ab= do addClause sat [ea, ab, varnot eb] + addClause sat [varnot ea,varnot ab,eb] + +noCyclesPr :: Sat -> ToChordal -> IO () +noCyclesPr sat g | IM.null g = return () + | otherwise = do + news <- sequence [ noTriangle sat g p q | (p,q) <- validPairs neighs] + let g' = adds (remove node neighs g) (concat news) + noCyclesPr sat g' + where + node = snd $ minimum [ (weight xs, a) + | (a,xs) <- IM.toList g ] + Just neighs = IM.lookup node g + validPairs ns = [ (p,q) | p <- sibs, q <- nsibs ] ++ + [ (p,q) | p <- nsibs, q <- anys ] ++ + [ (p,q) | p <- sibs, q <- anys ] + ++ (pairs anys) + where sibs = [ n | n@(_,Sib _) <- ns ] + nsibs= [ n | n@(_,NSib _) <- ns ] + anys = [ n | n@(_,Any _) <- ns ] + weight :: [Neigh] -> Int + weight xs = ss*3 * (ds + cs) + (ds + cs)^2 + where + ss = length [ x | x@(_,Sib _) <- xs ] + ds = length [ x | x@(_,NSib _) <- xs ] + cs = length [ x | x@(_,Any _) <- xs ] + +noTriangle :: Sat -> ToChordal -> Neigh -> Neigh -> IO [SatEdge] +noTriangle sat g e1@(t1,c1) e2@(t2,c2) = + case IM.lookup t1 g of + Just ns -> + case [ c | (t2',c) <- ns, t2' == t2 ] of + [] -> do p <- newLit sat + ruleOut c1 c2 (Any p) + return [(t1,(t2,(Any p)))] + [c3] -> ruleOut c1 c2 c3 >> return [] + _ -> error "multiple edges between two nodes" + Nothing -> error "pointer outside of graph" + where ruleOut ea eb ab= addClauses sat [[ea, ab, neg eb],[neg ea,neg ab,eb]] +noNtCycles :: Sat -> [Nt] -> (String -> IO ()) -> IO VarMap +noNtCycles sat tps putStrLn = do + putStrLn "--- Non-Terminals ---" + maps <- mapM forNt tps + return $ M.unions maps + where -- at non-terminal level, all cycles are between siblings + -- that is why we force all the edges to be the same + -- (not filtered by validPairs) + forNt tp@(Nt tid dpf dpt inhs syns _) = do + vars <- satValues sat + putStrLn ("nt : " ++ tid ++ " ... " ++ + show vars ++ " ...") + when (not $ S.null $ S.fromList dpf `S.intersection` + S.fromList (map (\(a,b) -> (b,a)) dpt)) $ + error "Type 2 cycle of length 2" + ass <- sequence $ + [ return ((i,s),VarTrue) | ((i,s)) <- dpf ]++ + [ return ((i,s),VarFalse)| ((s,i)) <- dpt ] + let assM = M.fromList ass + mvars<- sequence + [ if new then do + p <- newLit sat + return $ Just ((i,s),p) else return Nothing + | (i,_,_) <- inhs + , (s,_,_) <- syns + , let mmv = maybe (M.lookup (s,i) assM) Just + (M.lookup (i,s) assM) + new = isNothing mmv ] + let vars = ass ++ catMaybes mvars + g <- toNtGraph vars + noCyclesNt sat g + return $ M.fromList vars + + +noPrCycles :: Sat -> [Pr] -> VarMap -> (String -> IO ()) -> IO () +noPrCycles sat prods varMap putStrLn = do + putStrLn "--- Productions ---" + mapM_ forProd prods + where forProd (Pr prod es ses fs) | length fs ==1 = return () --taken care of + | otherwise = do + vars <- satValues sat + putStrLn ("prod: " ++ show prod ++ " ... " ++ + show vars ++ " ...") + g <- toChordal (sibs ++ dps) + noCyclesPr sat g + where sibs= [ ((f,t),Sib c) | (e@(f,t),ge,_) <- ses + , let c = case M.lookup ge varMap of + Just p -> p + Nothing -> error "no var found"] + dps = [ (e,NSib VarTrue) | e <- es ] + + +#else + +scheduleLOAG = error "You need to install uuagc with the -fwith-loag flag in order to use the --loag option." + +#endif diff --git a/src/LOAG/Common.hs b/src/LOAG/Common.hs --- a/src/LOAG/Common.hs +++ b/src/LOAG/Common.hs @@ -1,298 +1,298 @@ - -module LOAG.Common where - -import qualified Data.Array as A -import qualified Data.Map as M -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Set as S -import qualified Data.Sequence as Seq -import Data.Maybe (isNothing) -import Data.STRef -import Data.Array.ST -import Data.List (intercalate, foldl', nub) -import CommonTypes -import Control.Arrow -import Control.Monad.ST -import Control.Monad (forM, when, forM_, forM_, foldM) - -import LOAG.Graphs - -data Ag = Ag (Int,Int) -- attribute range - (Int,Int) -- occurrence range - [Edge] -- direct dependencies - [Nt] -- non-terminals -data Nt = Nt String - [Edge] -- direct dps from inh -> syn - [Edge] -- direct dps from syn -> inh - -- inh attributes with direction and instances - [(Vertex,[Vertex],Direction)] - -- syn attributes with direction and instances - [(Vertex,[Vertex],Direction)] - [Pr] -- productions of this Nt - deriving (Show) -data Pr = Pr PLabel - [Edge] -- direct dependencies between fields - [(Edge,Edge,Bool)] -- all siblings pairs, with generalised version, and boolean that denotes whether if it is an edge of LHS - [Fd] -- the fields of this production, including lhs - deriving (Show) -data Fd = Fd String -- field name - String -- type of the field - [(Vertex,Vertex)] -- inherited atts (gen, inst) - [(Vertex,Vertex)] -- synthesized atts (gen, inst) - deriving (Show) - -type Attrs = [Attr] -data Attr = Attr String Direction MyType - deriving (Show, Eq, Ord) -data Direction = Inh | AnyDir | Syn - deriving (Show, Ord, Enum) - - -foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a -foldM' _ a [] = return a -foldM' f a (x:xs) = f a x >>= \fax -> fax `seq` foldM f fax xs - -modifyArray r k f = do - v <- readArray r k - writeArray r k (f v) - -setConcatMap f = S.foldr (S.union . f) S.empty -isLoc (MyOccurrence (_,f) _) = f == "loc" || f == "inst" -- transparent occr ? - -instance Eq Direction where - Inh == Syn = False - Syn == Inh = False - _ == _ = True - -data MyType = TyInt - | TyBool - | TyString - | TyData String - | TyLit String - | TyArr MyType MyType - | NoType -- the empty set of values (no members) - | AnyType -- the set of all values (union of all types) - -type SchedRef s = (STArray s Vertex (Maybe Int),ThreadRef s) -type AttrAssRef s = STArray s Vertex (Maybe Int) -type ThreadRef s = STRef s InterfaceRes --- production is identified by its name and its parent non-terminal -type PLabel = (MyType,String) -type FLabel = String -- field label --- attribute is identified by its name and its direction -type ALabel = (String, Direction) -type AI_N = M.Map MyType MyAttributes -type AS_N = M.Map MyType MyAttributes -type A_N = M.Map MyType MyAttributes -type A_P = M.Map PLabel MyOccurrences --- Get the (data)type of a certain child at a certain production -type FTY = M.Map (PLabel, FLabel) MyType --- Get the fields corresponding to a certain type -type TYFS = M.Map MyType [(PLabel, FLabel)] --- the definition of given occ uses these occs -type SF_P = M.Map MyOccurrence (S.Set MyOccurrence) -type PMP = M.Map Int MyOccurrence -type PMP_R = M.Map MyOccurrence Int -type NMP = M.Map Int MyAttribute -type NMP_R = M.Map MyAttribute Int -type FMap = M.Map (PLabel,FLabel) (S.Set MyOccurrence, S.Set MyOccurrence) -type FsInP = M.Map PLabel [(PLabel, FLabel)] -type LOAGRes = ( Maybe TDPRes - , InterfaceRes - , ADSRes) -type VisCount= (Int, Int, Float) -type ADSRes = [Edge] -type TDPRes = A.Array Vertex Vertices --M.Map PLabel TDPGraph -type TDPGraph = (IM.IntMap Vertices, IM.IntMap Vertices) -type InterfaceRes = M.Map String (IM.IntMap [Vertex]) -type HOMap = M.Map PLabel (S.Set FLabel) -data CType = T1 | T2 - | T3 [Edge] -- completing edges from which to select candidates - deriving (Show) - -findWithErr :: (Ord k, Show k, Show a) => M.Map k a -> String -> k -> a -findWithErr m err k = maybe (error err) id $ M.lookup k m -findWithErr' m err k= maybe (error err) id $ IM.lookup k m - --- Defining the MyAttribute (attribute at non-terimal --- and the MyOccurrences (attribute at a production) -type MyAttributes = [MyAttribute] -data MyAttribute = MyAttribute {typeOf :: MyType, alab :: ALabel} - deriving (Ord, Eq) -(<.>) = MyAttribute -infixl 7 <.> -instance Show MyAttribute where - show (MyAttribute t a) = show t ++ "<.>" ++ show a - -type MyOccurrences = [MyOccurrence] -data MyOccurrence = MyOccurrence {argsOf :: (PLabel, FLabel), attr :: ALabel} - deriving (Ord, Eq) -(>.<) = MyOccurrence -infixl 8 >.< -instance Show MyOccurrence where - show (MyOccurrence ((t,p),f) a) = - intercalate "." [show t,p,f] ++ "."++ show a - -dirOfOcc :: MyOccurrence -> Direction -dirOfOcc = snd . attr - -handOut :: (PLabel, FLabel) -> MyAttribute -> MyOccurrence -handOut p = (p >.<) . alab - -handAllOut :: (PLabel, FLabel) -> MyAttributes -> MyOccurrences -handAllOut p os = map (handOut p) os - -map2F :: (Ord a) => M.Map a [b] -> a -> [b] -map2F m a = case M.lookup a m of - Nothing -> [] - Just bs -> bs - -map2F' :: (Ord a) => M.Map a (S.Set b) -> a -> (S.Set b) -map2F' m a = case M.lookup a m of - Nothing -> S.empty - Just bs -> bs - -flipDir :: Direction -> Direction -flipDir Syn = Inh -flipDir Inh = Syn - --- creates all pairs of elements such that no equal elements end up in a pair --- and considering only one direction -pairs :: [a] -> [(a,a)] -pairs [] = [] -pairs (x:xs) = map ((,) x) xs ++ pairs xs - -toMyTy :: Type -> MyType -toMyTy (Haskell str) = TyLit str -toMyTy (NT id _ _ ) = TyData $ getName id -toMyTy Self = error "Type Self in phase 3" - -fromMyTy :: MyType -> Type -fromMyTy (TyLit str) = (Haskell str) -fromMyTy (TyData id) = NT (identifier id) [] False - -toMyAttr :: Direction -> MyType -> Attributes -> MyAttributes -toMyAttr d dty = M.foldrWithKey - (\ident ty as -> dty <.> (getName ident,d):as) [] - -completing :: FrGraph -> SchedRef s -> [Nt] -> ST s InterfaceRes -completing ids sched nts = do - ims <- forM nts $ completingN ids (fst sched) - let threads = (M.fromList ims) - writeSTRef (snd sched) threads - return $ threads - -completingN :: FrGraph -> AttrAssRef s -> Nt -> - ST s ((String, IM.IntMap [Vertex])) -completingN ids@(idsf, idst) schedA - (Nt nt_id _ _ inhs syns _) = do - schedS <- newSTRef IM.empty - let attrs = inhs ++ syns - dty = TyData nt_id - assign (attr,_,dAttr) = do - let succs = idsf A.! attr - assigned <- freeze schedA - when (isNothing $ assigned A.! attr) $ do - case IS.toList succs of - [] ->wrap_up attr(if Syn==dAttr then 1 else 2) - ss ->case selMax $ map (id&&&(assigned A.!)) ss of - Nothing -> return () - Just (a,mx) -> do - let dA | even mx = Inh - | otherwise = Syn - wrap_up attr (if dA == dAttr - then mx else mx+1) - wrap_up attr k = do - modifySTRef schedS (IM.insertWith (++) k [attr]) - writeArray schedA attr (Just k) - forM_ attrs assign - selMax :: [(Vertex, Maybe Int)] -> Maybe (Vertex, Int) - selMax [(v,mi)] = fmap ((,) v) mi - selMax (x:xs) = case x of - (a', Nothing) -> Nothing - (a', Just i') -> - case selMax xs of - Nothing -> Nothing - Just (a,i) -> - case compare i i' of - LT -> Just (a',i') - _ -> Just (a,i) - --make sure all are assigned - case attrs of - [] -> return (nt_id, IM.fromList [(1,[]),(2,[])]) - as -> forM_ as assign >> readSTRef schedS >>= return . ((,) nt_id) - -fetchEdges :: FrGraph -> InterfaceRes -> [Nt] -> ([Edge],[Edge]) -fetchEdges ids threads nts = - let ivdNs = map (fetchEdgesN ids threads) nts - in (concat *** concat) $ unzip ivdNs - -fetchEdgesN :: FrGraph -> InterfaceRes -> Nt - -> ([Edge],[Edge]) -fetchEdgesN (idsf, idst) threads - (Nt nt_id _ _ _ _ _) = - let sched = findWithErr threads "schedule err" nt_id - mx = if IM.null sched then 0 else fst $ IM.findMax sched - findK 0 = [] - findK k = (maybe [] id $ IM.lookup k sched) ++ findK (k-1) - ivd = [ (f,t) | k <- [2..mx] - , f <- maybe [] id $ IM.lookup k sched - , t <- findK (k-1)] - in (ivd, [ (f, t) | (f, t) <- ivd - , not $ IS.member t (idsf A.! f) ]) - -instance Show MyType where - show TyInt = "Int" - show TyBool = "Bool" - show TyString = "String" - show (TyData t) = t - show (TyLit t) = show t - show (TyArr a b) = show a ++ " -> (" ++ show b ++ ")" - show NoType = error "Trying to show NoType" - show AnyType = "AnyType" - --- | Instance for Eq and Ord are required to make sure that AnyType --- | Equals every other type in every other situation -instance Eq MyType where - TyInt == TyInt = True - TyBool == TyBool = True - TyString == TyString = True - TyData n == TyData n' = n == n' - TyLit ty == TyLit ty' = ty == ty' - TyArr l r == TyArr l' r' = l == l' && r == r' - NoType == _ = False - _ == NoType = False - AnyType == _ = True - _ == AnyType = True - _ == _ = False - -instance Ord MyType where - NoType `compare` _ = LT - _ `compare` NoType = GT - AnyType `compare` _ = EQ - _ `compare` AnyType = EQ - TyInt `compare` TyInt = EQ - TyInt `compare` _ = LT - TyBool `compare` TyInt = GT - TyBool `compare` TyBool = EQ - TyBool `compare` _ = LT - TyString `compare` TyInt = GT - TyString `compare` TyBool = GT - TyString `compare` TyString = EQ - TyString `compare` _ = LT - TyData _ `compare` TyInt = GT - TyData _ `compare` TyBool = GT - TyData _ `compare` TyString = GT - TyData a `compare` TyData b = compare a b - TyData _ `compare` _ = LT - TyLit a `compare` TyLit b = compare a b - TyLit _ `compare` TyArr _ _= LT - TyLit _ `compare` _ = GT - TyArr a a' `compare` TyArr b b' = - case compare a b of - LT -> LT - GT -> GT - EQ -> compare a' b' - TyArr _ _ `compare` _ = GT - + +module LOAG.Common where + +import qualified Data.Array as A +import qualified Data.Map as M +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Set as S +import qualified Data.Sequence as Seq +import Data.Maybe (isNothing) +import Data.STRef +import Data.Array.ST +import Data.List (intercalate, foldl', nub) +import CommonTypes +import Control.Arrow +import Control.Monad.ST +import Control.Monad (forM, when, forM_, forM_, foldM) + +import LOAG.Graphs + +data Ag = Ag (Int,Int) -- attribute range + (Int,Int) -- occurrence range + [Edge] -- direct dependencies + [Nt] -- non-terminals +data Nt = Nt String + [Edge] -- direct dps from inh -> syn + [Edge] -- direct dps from syn -> inh + -- inh attributes with direction and instances + [(Vertex,[Vertex],Direction)] + -- syn attributes with direction and instances + [(Vertex,[Vertex],Direction)] + [Pr] -- productions of this Nt + deriving (Show) +data Pr = Pr PLabel + [Edge] -- direct dependencies between fields + [(Edge,Edge,Bool)] -- all siblings pairs, with generalised version, and boolean that denotes whether if it is an edge of LHS + [Fd] -- the fields of this production, including lhs + deriving (Show) +data Fd = Fd String -- field name + String -- type of the field + [(Vertex,Vertex)] -- inherited atts (gen, inst) + [(Vertex,Vertex)] -- synthesized atts (gen, inst) + deriving (Show) + +type Attrs = [Attr] +data Attr = Attr String Direction MyType + deriving (Show, Eq, Ord) +data Direction = Inh | AnyDir | Syn + deriving (Show, Ord, Enum) + + +foldM' :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a +foldM' _ a [] = return a +foldM' f a (x:xs) = f a x >>= \fax -> fax `seq` foldM f fax xs + +modifyArray r k f = do + v <- readArray r k + writeArray r k (f v) + +setConcatMap f = S.foldr (S.union . f) S.empty +isLoc (MyOccurrence (_,f) _) = f == "loc" || f == "inst" -- transparent occr ? + +instance Eq Direction where + Inh == Syn = False + Syn == Inh = False + _ == _ = True + +data MyType = TyInt + | TyBool + | TyString + | TyData String + | TyLit String + | TyArr MyType MyType + | NoType -- the empty set of values (no members) + | AnyType -- the set of all values (union of all types) + +type SchedRef s = (STArray s Vertex (Maybe Int),ThreadRef s) +type AttrAssRef s = STArray s Vertex (Maybe Int) +type ThreadRef s = STRef s InterfaceRes +-- production is identified by its name and its parent non-terminal +type PLabel = (MyType,String) +type FLabel = String -- field label +-- attribute is identified by its name and its direction +type ALabel = (String, Direction) +type AI_N = M.Map MyType MyAttributes +type AS_N = M.Map MyType MyAttributes +type A_N = M.Map MyType MyAttributes +type A_P = M.Map PLabel MyOccurrences +-- Get the (data)type of a certain child at a certain production +type FTY = M.Map (PLabel, FLabel) MyType +-- Get the fields corresponding to a certain type +type TYFS = M.Map MyType [(PLabel, FLabel)] +-- the definition of given occ uses these occs +type SF_P = M.Map MyOccurrence (S.Set MyOccurrence) +type PMP = M.Map Int MyOccurrence +type PMP_R = M.Map MyOccurrence Int +type NMP = M.Map Int MyAttribute +type NMP_R = M.Map MyAttribute Int +type FMap = M.Map (PLabel,FLabel) (S.Set MyOccurrence, S.Set MyOccurrence) +type FsInP = M.Map PLabel [(PLabel, FLabel)] +type LOAGRes = ( Maybe TDPRes + , InterfaceRes + , ADSRes) +type VisCount= (Int, Int, Float) +type ADSRes = [Edge] +type TDPRes = A.Array Vertex Vertices --M.Map PLabel TDPGraph +type TDPGraph = (IM.IntMap Vertices, IM.IntMap Vertices) +type InterfaceRes = M.Map String (IM.IntMap [Vertex]) +type HOMap = M.Map PLabel (S.Set FLabel) +data CType = T1 | T2 + | T3 [Edge] -- completing edges from which to select candidates + deriving (Show) + +findWithErr :: (Ord k, Show k, Show a) => M.Map k a -> String -> k -> a +findWithErr m err k = maybe (error err) id $ M.lookup k m +findWithErr' m err k= maybe (error err) id $ IM.lookup k m + +-- Defining the MyAttribute (attribute at non-terimal +-- and the MyOccurrences (attribute at a production) +type MyAttributes = [MyAttribute] +data MyAttribute = MyAttribute {typeOf :: MyType, alab :: ALabel} + deriving (Ord, Eq) +(<.>) = MyAttribute +infixl 7 <.> +instance Show MyAttribute where + show (MyAttribute t a) = show t ++ "<.>" ++ show a + +type MyOccurrences = [MyOccurrence] +data MyOccurrence = MyOccurrence {argsOf :: (PLabel, FLabel), attr :: ALabel} + deriving (Ord, Eq) +(>.<) = MyOccurrence +infixl 8 >.< +instance Show MyOccurrence where + show (MyOccurrence ((t,p),f) a) = + intercalate "." [show t,p,f] ++ "."++ show a + +dirOfOcc :: MyOccurrence -> Direction +dirOfOcc = snd . attr + +handOut :: (PLabel, FLabel) -> MyAttribute -> MyOccurrence +handOut p = (p >.<) . alab + +handAllOut :: (PLabel, FLabel) -> MyAttributes -> MyOccurrences +handAllOut p os = map (handOut p) os + +map2F :: (Ord a) => M.Map a [b] -> a -> [b] +map2F m a = case M.lookup a m of + Nothing -> [] + Just bs -> bs + +map2F' :: (Ord a) => M.Map a (S.Set b) -> a -> (S.Set b) +map2F' m a = case M.lookup a m of + Nothing -> S.empty + Just bs -> bs + +flipDir :: Direction -> Direction +flipDir Syn = Inh +flipDir Inh = Syn + +-- creates all pairs of elements such that no equal elements end up in a pair +-- and considering only one direction +pairs :: [a] -> [(a,a)] +pairs [] = [] +pairs (x:xs) = map ((,) x) xs ++ pairs xs + +toMyTy :: Type -> MyType +toMyTy (Haskell str) = TyLit str +toMyTy (NT id _ _ ) = TyData $ getName id +toMyTy Self = error "Type Self in phase 3" + +fromMyTy :: MyType -> Type +fromMyTy (TyLit str) = (Haskell str) +fromMyTy (TyData id) = NT (identifier id) [] False + +toMyAttr :: Direction -> MyType -> Attributes -> MyAttributes +toMyAttr d dty = M.foldrWithKey + (\ident ty as -> dty <.> (getName ident,d):as) [] + +completing :: FrGraph -> SchedRef s -> [Nt] -> ST s InterfaceRes +completing ids sched nts = do + ims <- forM nts $ completingN ids (fst sched) + let threads = (M.fromList ims) + writeSTRef (snd sched) threads + return $ threads + +completingN :: FrGraph -> AttrAssRef s -> Nt -> + ST s ((String, IM.IntMap [Vertex])) +completingN ids@(idsf, idst) schedA + (Nt nt_id _ _ inhs syns _) = do + schedS <- newSTRef IM.empty + let attrs = inhs ++ syns + dty = TyData nt_id + assign (attr,_,dAttr) = do + let succs = idsf A.! attr + assigned <- freeze schedA + when (isNothing $ assigned A.! attr) $ do + case IS.toList succs of + [] ->wrap_up attr(if Syn==dAttr then 1 else 2) + ss ->case selMax $ map (id&&&(assigned A.!)) ss of + Nothing -> return () + Just (a,mx) -> do + let dA | even mx = Inh + | otherwise = Syn + wrap_up attr (if dA == dAttr + then mx else mx+1) + wrap_up attr k = do + modifySTRef schedS (IM.insertWith (++) k [attr]) + writeArray schedA attr (Just k) + forM_ attrs assign + selMax :: [(Vertex, Maybe Int)] -> Maybe (Vertex, Int) + selMax [(v,mi)] = fmap ((,) v) mi + selMax (x:xs) = case x of + (a', Nothing) -> Nothing + (a', Just i') -> + case selMax xs of + Nothing -> Nothing + Just (a,i) -> + case compare i i' of + LT -> Just (a',i') + _ -> Just (a,i) + --make sure all are assigned + case attrs of + [] -> return (nt_id, IM.fromList [(1,[]),(2,[])]) + as -> forM_ as assign >> readSTRef schedS >>= return . ((,) nt_id) + +fetchEdges :: FrGraph -> InterfaceRes -> [Nt] -> ([Edge],[Edge]) +fetchEdges ids threads nts = + let ivdNs = map (fetchEdgesN ids threads) nts + in (concat *** concat) $ unzip ivdNs + +fetchEdgesN :: FrGraph -> InterfaceRes -> Nt + -> ([Edge],[Edge]) +fetchEdgesN (idsf, idst) threads + (Nt nt_id _ _ _ _ _) = + let sched = findWithErr threads "schedule err" nt_id + mx = if IM.null sched then 0 else fst $ IM.findMax sched + findK 0 = [] + findK k = (maybe [] id $ IM.lookup k sched) ++ findK (k-1) + ivd = [ (f,t) | k <- [2..mx] + , f <- maybe [] id $ IM.lookup k sched + , t <- findK (k-1)] + in (ivd, [ (f, t) | (f, t) <- ivd + , not $ IS.member t (idsf A.! f) ]) + +instance Show MyType where + show TyInt = "Int" + show TyBool = "Bool" + show TyString = "String" + show (TyData t) = t + show (TyLit t) = show t + show (TyArr a b) = show a ++ " -> (" ++ show b ++ ")" + show NoType = error "Trying to show NoType" + show AnyType = "AnyType" + +-- | Instance for Eq and Ord are required to make sure that AnyType +-- | Equals every other type in every other situation +instance Eq MyType where + TyInt == TyInt = True + TyBool == TyBool = True + TyString == TyString = True + TyData n == TyData n' = n == n' + TyLit ty == TyLit ty' = ty == ty' + TyArr l r == TyArr l' r' = l == l' && r == r' + NoType == _ = False + _ == NoType = False + AnyType == _ = True + _ == AnyType = True + _ == _ = False + +instance Ord MyType where + NoType `compare` _ = LT + _ `compare` NoType = GT + AnyType `compare` _ = EQ + _ `compare` AnyType = EQ + TyInt `compare` TyInt = EQ + TyInt `compare` _ = LT + TyBool `compare` TyInt = GT + TyBool `compare` TyBool = EQ + TyBool `compare` _ = LT + TyString `compare` TyInt = GT + TyString `compare` TyBool = GT + TyString `compare` TyString = EQ + TyString `compare` _ = LT + TyData _ `compare` TyInt = GT + TyData _ `compare` TyBool = GT + TyData _ `compare` TyString = GT + TyData a `compare` TyData b = compare a b + TyData _ `compare` _ = LT + TyLit a `compare` TyLit b = compare a b + TyLit _ `compare` TyArr _ _= LT + TyLit _ `compare` _ = GT + TyArr a a' `compare` TyArr b b' = + case compare a b of + LT -> LT + GT -> GT + EQ -> compare a' b' + TyArr _ _ `compare` _ = GT + diff --git a/src/LOAG/Graphs.hs b/src/LOAG/Graphs.hs --- a/src/LOAG/Graphs.hs +++ b/src/LOAG/Graphs.hs @@ -1,155 +1,155 @@ -module LOAG.Graphs where - -import Control.Monad (forM, forM_) -import Control.Monad.ST -import Control.Monad.State -import CommonTypes -import Data.STRef -import Data.Maybe (catMaybes, isNothing, fromJust) -import Data.Tuple (swap) -import qualified Data.Array as A -import Data.Array.IArray (amap) -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Array.MArray (mapArray) -import Data.Array.ST - -type Schedule = (A.Array Vertex (Maybe Int), A.Array Int [Vertex]) -type Vertex = Int -type Cycle = IS.IntSet -type Vertices = IS.IntSet -type Edge = (Vertex, Vertex) -type Edges = S.Set Edge --- Maps that are suitable for Graphs (from 1 node to a set of nodes) -type Graph s = (DirGraphRef s, DirGraphRef s) --- | Frozen version of a graph -type FrGraph = (DirGraph, DirGraph) -type DirGraph = A.Array Vertex Vertices -type DirGraphRef s = STArray s Vertex Vertices - --- |---------------------------------------------------------------------- --- | Functions for changing the state within AOAG --- | possibly catching errors from creating cycles - -addEDs :: Graph s -> [Edge] -> (ST s) (Maybe (Edge, Cycle)) -addEDs _ [] = return Nothing -addEDs edp (e:es) = do - res <- e `inserT` edp - case res of - Right _ -> addEDs edp es - Left c -> return $ Just (e,c) - --- | Draws an edge from one node to another, by adding the latter to the --- node set of the first -insErt :: Edge -> Graph s -> (ST s) () -insErt (f, t) g@(ft,tf) = do - ts <- readArray ft f - fs <- readArray tf t - writeArray ft f (t `IS.insert` ts) - writeArray tf t (f `IS.insert` fs) - -removE :: Edge -> Graph s -> (ST s) () -removE e@(f,t) g@(ft,tf) = do - ts <- readArray ft f - fs <- readArray tf t - writeArray ft f (t `IS.delete` ts) - writeArray tf t (f `IS.delete` fs) - - --- | Revert an edge in the graph -revErt :: Edge -> Graph s -> (ST s) () -revErt e g = do - present <- member e g - when present $ removE e g >> insErt (swap e) g - --- | Assuming the given graph is already transitively closed, and --- | not cyclic, insert an --- | edge such that the graph maintains transitively closed. --- | returns the cycle if this results in a cycle or returns a pair --- | (graph, edges) if not. Where graph is the new Graph and --- | edges represent the edges that were required for transitively --- | closing the graph. -inserT :: Edge -> Graph s -> (ST s) (Either Cycle [Edge]) -inserT e@(f, t) g@(gft,gtf) - | f == t = return $ Left $ IS.singleton f - | otherwise = do - present <- member e g - if present - then (return $ Right []) - else do - rs <- readArray gtf f - us <- readArray gft t - pointsToF <- readArray gtf f - pointsToT <- readArray gtf t - tPointsTo <- readArray gft t - let new2t = pointsToF IS.\\ pointsToT - -- extras from f connects all new nodes pointing to f with t - let extraF = IS.foldl' (\acc tf -> (tf,t) : acc) [] new2t - -- extras of t connects all nodes that will be pointing to t - -- in the new graph, with all the nodes t points to in the - -- current graph - all2tPointsTo <- newSTRef [] - forM_ (IS.toList tPointsTo) $ \ft -> do - current <- readSTRef all2tPointsTo - existing <- readArray gtf ft - let new4ft = map (flip (,) ft) $ IS.toList $ - -- removing existing here matters a lot - (f `IS.insert` pointsToF) IS.\\ existing - writeSTRef all2tPointsTo $ current ++ new4ft - - extraT <- readSTRef all2tPointsTo - -- the extras consists of extras from f and extras from t - -- both these extra sets dont contain edges if they are already - -- present in the old graph - let extra = extraF ++ extraT - mapM_ (`insErt` g) (e : extra) - -- the new graph contains a cycle if there is a self-edge - -- this cycle will contain both f and t - cyclic <- member (f,f) g - if cyclic - then do - cycle <- getCycle gft - return $ Left cycle - else return $ Right extra - - where - -- given that there is a cycle,all elements of this cycle are being - -- pointed at by f. However, not all elements that f points to are - -- part of the cycle. Only those that point back to f. - getCycle :: STArray s Vertex Vertices -> (ST s) Cycle - getCycle gft = do - ts <- readArray gft f - mnodes <- forM (IS.toList ts) $ \t' -> do - fs' <- readArray gft t' - if f `IS.member` fs' - then return $ Just t' - else return $ Nothing - return $ IS.fromList $ catMaybes mnodes - --- | Check if a certain edge is part of a graph which means that, --- | the receiving node must be in the node set of the sending -member :: Edge -> Graph s -> (ST s) Bool -member (f, t) (ft, tf) = do - ts <- readArray ft f - return $ IS.member t ts - --- | Check whether an edge is part of a frozen graph -fr_member :: FrGraph -> Edge -> Bool -fr_member (ft, tf) (f, t) = IS.member t (ft A.! f) - --- | Flatten a graph, meaning that we transform this graph to --- | a set of Edges by combining a sending node with all the --- | receiving nodes in its node set -flatten :: Graph s -> (ST s) Edges -flatten (gft, _) = do - list <- getAssocs gft - return $ S.fromList $ concatMap - (\(f, ts) -> map ((,) f) $ IS.toList ts) list - -freeze_graph :: Graph s -> (ST s) FrGraph -freeze_graph (mf, mt) = do - fr_f <- freeze mf - fr_t <- freeze mt - return (fr_f, fr_t) +module LOAG.Graphs where + +import Control.Monad (forM, forM_) +import Control.Monad.ST +import Control.Monad.State +import CommonTypes +import Data.STRef +import Data.Maybe (catMaybes, isNothing, fromJust) +import Data.Tuple (swap) +import qualified Data.Array as A +import Data.Array.IArray (amap) +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Array.MArray (mapArray) +import Data.Array.ST + +type Schedule = (A.Array Vertex (Maybe Int), A.Array Int [Vertex]) +type Vertex = Int +type Cycle = IS.IntSet +type Vertices = IS.IntSet +type Edge = (Vertex, Vertex) +type Edges = S.Set Edge +-- Maps that are suitable for Graphs (from 1 node to a set of nodes) +type Graph s = (DirGraphRef s, DirGraphRef s) +-- | Frozen version of a graph +type FrGraph = (DirGraph, DirGraph) +type DirGraph = A.Array Vertex Vertices +type DirGraphRef s = STArray s Vertex Vertices + +-- |---------------------------------------------------------------------- +-- | Functions for changing the state within AOAG +-- | possibly catching errors from creating cycles + +addEDs :: Graph s -> [Edge] -> (ST s) (Maybe (Edge, Cycle)) +addEDs _ [] = return Nothing +addEDs edp (e:es) = do + res <- e `inserT` edp + case res of + Right _ -> addEDs edp es + Left c -> return $ Just (e,c) + +-- | Draws an edge from one node to another, by adding the latter to the +-- node set of the first +insErt :: Edge -> Graph s -> (ST s) () +insErt (f, t) g@(ft,tf) = do + ts <- readArray ft f + fs <- readArray tf t + writeArray ft f (t `IS.insert` ts) + writeArray tf t (f `IS.insert` fs) + +removE :: Edge -> Graph s -> (ST s) () +removE e@(f,t) g@(ft,tf) = do + ts <- readArray ft f + fs <- readArray tf t + writeArray ft f (t `IS.delete` ts) + writeArray tf t (f `IS.delete` fs) + + +-- | Revert an edge in the graph +revErt :: Edge -> Graph s -> (ST s) () +revErt e g = do + present <- member e g + when present $ removE e g >> insErt (swap e) g + +-- | Assuming the given graph is already transitively closed, and +-- | not cyclic, insert an +-- | edge such that the graph maintains transitively closed. +-- | returns the cycle if this results in a cycle or returns a pair +-- | (graph, edges) if not. Where graph is the new Graph and +-- | edges represent the edges that were required for transitively +-- | closing the graph. +inserT :: Edge -> Graph s -> (ST s) (Either Cycle [Edge]) +inserT e@(f, t) g@(gft,gtf) + | f == t = return $ Left $ IS.singleton f + | otherwise = do + present <- member e g + if present + then (return $ Right []) + else do + rs <- readArray gtf f + us <- readArray gft t + pointsToF <- readArray gtf f + pointsToT <- readArray gtf t + tPointsTo <- readArray gft t + let new2t = pointsToF IS.\\ pointsToT + -- extras from f connects all new nodes pointing to f with t + let extraF = IS.foldl' (\acc tf -> (tf,t) : acc) [] new2t + -- extras of t connects all nodes that will be pointing to t + -- in the new graph, with all the nodes t points to in the + -- current graph + all2tPointsTo <- newSTRef [] + forM_ (IS.toList tPointsTo) $ \ft -> do + current <- readSTRef all2tPointsTo + existing <- readArray gtf ft + let new4ft = map (flip (,) ft) $ IS.toList $ + -- removing existing here matters a lot + (f `IS.insert` pointsToF) IS.\\ existing + writeSTRef all2tPointsTo $ current ++ new4ft + + extraT <- readSTRef all2tPointsTo + -- the extras consists of extras from f and extras from t + -- both these extra sets dont contain edges if they are already + -- present in the old graph + let extra = extraF ++ extraT + mapM_ (`insErt` g) (e : extra) + -- the new graph contains a cycle if there is a self-edge + -- this cycle will contain both f and t + cyclic <- member (f,f) g + if cyclic + then do + cycle <- getCycle gft + return $ Left cycle + else return $ Right extra + + where + -- given that there is a cycle,all elements of this cycle are being + -- pointed at by f. However, not all elements that f points to are + -- part of the cycle. Only those that point back to f. + getCycle :: STArray s Vertex Vertices -> (ST s) Cycle + getCycle gft = do + ts <- readArray gft f + mnodes <- forM (IS.toList ts) $ \t' -> do + fs' <- readArray gft t' + if f `IS.member` fs' + then return $ Just t' + else return $ Nothing + return $ IS.fromList $ catMaybes mnodes + +-- | Check if a certain edge is part of a graph which means that, +-- | the receiving node must be in the node set of the sending +member :: Edge -> Graph s -> (ST s) Bool +member (f, t) (ft, tf) = do + ts <- readArray ft f + return $ IS.member t ts + +-- | Check whether an edge is part of a frozen graph +fr_member :: FrGraph -> Edge -> Bool +fr_member (ft, tf) (f, t) = IS.member t (ft A.! f) + +-- | Flatten a graph, meaning that we transform this graph to +-- | a set of Edges by combining a sending node with all the +-- | receiving nodes in its node set +flatten :: Graph s -> (ST s) Edges +flatten (gft, _) = do + list <- getAssocs gft + return $ S.fromList $ concatMap + (\(f, ts) -> map ((,) f) $ IS.toList ts) list + +freeze_graph :: Graph s -> (ST s) FrGraph +freeze_graph (mf, mt) = do + fr_f <- freeze mf + fr_t <- freeze mt + return (fr_f, fr_t) diff --git a/src/LOAG/Optimise.hs b/src/LOAG/Optimise.hs --- a/src/LOAG/Optimise.hs +++ b/src/LOAG/Optimise.hs @@ -1,304 +1,304 @@ - -module LOAG.Optimise where - -import LOAG.Common -import LOAG.Graphs -import LOAG.Solver.MiniSat - -import Control.Arrow ((&&&)) -import Control.Monad (forM, forM_, when, foldM) -import Control.Monad.ST -import Data.Array.MArray -import Data.Array.IO -import Data.Function (on) -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as M -import Data.Maybe (fromJust, isJust) -import Data.List (intercalate, sort, sortBy) - -type Opts = [Opt] -data Opt= Smaller (Vertex) (Vertex) -- x < y - | Greater (Vertex) (Vertex) -- x > y - | AllSmaller (Vertex) Direction -- _ < x - | AllGreater (Vertex) Direction -- _ > x - | MinVisits - deriving (Ord, Eq) - -instance Show Opt where - show (Smaller f t) = show f ++ " --> " ++ show t - show (Greater f t) = show f ++ " <-- " ++ show t - show (AllSmaller f _) = " _ --> " ++ show f - show (AllGreater f _) = " _ <-- " ++ show f - show MinVisits = " Minimising #visits " - - -optimise :: Sat -> VarMap -> Opts -> (Int,Int) -> [Nt] -> InterfaceRes -> IO () -optimise sat varMap opts nbounds nts interfaces = do - let scheduler = newSchedule sat varMap nbounds - mapM_ (singleOpt sat varMap scheduler nts interfaces) (sort opts) - b <- satsolve sat [] - return () - --- | Given a non-terminal and a current best schedule --- return a new best schedule and whether the new schedule is truely new -type SchedulerNt = Nt -> IM.IntMap [Vertex] -> IO (Bool, IM.IntMap [Vertex]) -type Scheduler = IM.IntMap [Vertex] -> IO (Bool, IM.IntMap [Vertex]) - -singleOpt :: Sat -> VarMap -> SchedulerNt -> [Nt] -> InterfaceRes -> Opt -> - IO () -singleOpt sat varMap scheduler nts interfaces opt = do - success <- - case opt of - Smaller f t -> tryPair sat $ varOf f t - Greater f t -> tryPair sat $ varOf t f - AllSmaller f d -> trySingle sat False f d varMap - AllGreater f d -> trySingle sat True f d varMap - MinVisits -> do mapM_ (minPaths sat varMap scheduler interfaces) $ - sortNfilter weigh nts - return True - return () - where weigh (Nt _ _ _ is ss _) = size - where size = length is + length ss - varOf f t = case M.lookup (f,t) varMap of - Just v -> v - Nothing -> case M.lookup (t,f) varMap of - Just v -> varnot v - Nothing -> error "invalid optimisation.." - -sortNfilter :: (a -> Int) -> [a] -> [a] -sortNfilter f = - map fst . sortBy (on compare snd) . - filter (((/=) 0) . snd) . map (id &&& f) - -minPaths :: Sat -> VarMap -> SchedulerNt -> InterfaceRes -> Nt -> IO Bool -minPaths sat varMap scheduler interfaces tp@(Nt nt _ _ is ss _) = do - forM_ neckCs $ attemptGroup sat (scheduler tp) mym . map varnot - return True - where neckCs= map (\(_,es,b) -> map (uncurry (mvar b)) es) $ - bottlenecks mx mym - mvar b f t | b = varMap M.! (f,t) - | not b = varnot $ varMap M.! (t,f) - mym = interfaces M.! nt - mx | IM.null mym = 0 - | otherwise = fst $ IM.findMax mym - -bottlenecks :: Int -> IM.IntMap [Vertex] -> - [(((Int,[Vertex]),(Int,[Vertex])),[Edge],Bool)] -bottlenecks x shd = - sortNfilter cost $ pairs x - where pairs x | x <= 1 = [] - | x > 1 = let pair = ((x,maybe [] id $ IM.lookup x shd) - ,(x-1,maybe [] id$IM.lookup (x-1) shd)) - in (pair,edges pair,even x) : pairs (x-1) - cost (((p1,p1s),(p2,p2s)),es,_) = size - where size = length es - edges ((p1,p1s),(p2,p2s)) = [ (f,t) | f <- p1s, t <- p2s ] - --- | get all combinations of partitions from different `directions' --- ordered by distance (shortest paths first) -edgeCombs :: Int -> IM.IntMap [Vertex] -> [(Int,Int)] -edgeCombs x shd = - sortBy (on compare cost) $ - concat $ - takeWhile (not . null) $ - map (\(n,es) -> filter ((>0) . snd) - (map (\(f,t) -> (f+n,t+n)) es)) $ - zip [-0,-1..] $ - repeat (map ((,) x) [x-1,x-3..1]) - where cost (x1,x2) = length $ findK (x1 -1) - where findK n | n < x2 = [] - | n >= x2 = (shd IM.! n) ++ findK (n-2) - -tryPair :: Sat -> MyVar -> IO Bool -tryPair sat p = do - b <- satsolve sat [p] - if b then addClause sat [p] - else return False - -attemptGroup :: Sat -> Scheduler -> IM.IntMap [Vertex] -> [MyVar] -> - IO (IM.IntMap [Vertex]) -attemptGroup sat scheduler interfaces = - tryGroup sat scheduler interfaces . filter notSet - where notSet (Var _) = True - notSet (VarNot v) = notSet v - notSet _ = False - -tryGroup :: Sat -> Scheduler -> IM.IntMap [Vertex] -> [MyVar] -> - IO (IM.IntMap [Vertex]) -tryGroup _ _ interfaces [] = return interfaces -tryGroup sat scheduler interfaces ps = do - xs <- mapM (const (newLit sat)) ps - mapM (\(a,r) -> addClause sat [varnot a, r]) $ zip xs ps - b <- satsolve sat xs - let success = assertVars sat xs - fail = assertVars sat (map varnot (xs++ps)) >> satsolve sat [] - if b then do (improved, sched) <- scheduler interfaces - if improved - then success >> return sched - else fail >> return interfaces - else fail >> return interfaces - -assertVars :: Sat -> [MyVar] -> IO () -assertVars sat vars = do bs <- mapM (addClause sat . (:[])) vars - return () - -trySingle :: Sat -> Bool -> Vertex -> Direction -> VarMap -> IO Bool -trySingle sat des f dir varMap = do - vars <- tryExtreme sat des literals - assertVars sat vars - return True - where literals = M.foldrWithKey select [] varMap - select k a b | fst k == f = a : b --inh - | snd k == f = varnot a : b --syn - | otherwise = b - -tryExtreme :: Sat -> Bool -> [MyVar] -> IO [MyVar] -tryExtreme sat des xs = - do a <- newLit sat - switch <- newLit sat - let try xs = - do --putStrLn ("currently, " ++ show (length xs) ++ " literals") - let assertOne | des = map varnot (a : xs) - | otherwise = varnot a : xs - addClause sat assertOne --"if a, then one of xs must be ~des" - b <- satsolve sat [a] - if b then - do xbs <- sequence [ do v <- value sat x - return (x,v) - | x <- xs - ] - sequence_ [ do let desx | des = x - | otherwise = varnot x - addClause sat [varnot a, desx] - addClause sat [varnot switch, desx] - | (x,b) <- xbs, b /= Just des ] - try [ x | (x,Just des) <- xbs ] - else do addClause sat [varnot a] - return [switch] - in try xs - --- | Recalculate interface based on SAT and compare with a given one -newSchedule :: Sat -> VarMap -> (Int,Int) -> Nt -> IM.IntMap [Vertex] -> - IO (Bool, IM.IntMap [Vertex]) -newSchedule sat varMap nbounds tp@(Nt nt _ _ inhs outs _ ) sched = do - idsf <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices) - idst <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices) - let ids = (idsf,idst) - sequence_ [ do v <- value sat pred - case v of - Nothing -> error "no val" - Just True -> addEdges (i,s) ids - Just False-> addEdges (s,i) ids - | (i,ios,_) <- inhs - , (s,sos,_) <- outs - , let pred = varMap M.! (i,s) - ] - f_idsf <- freeze idsf - f_idst <- freeze idst - let (_,newinterface) = runST $ do schedA <- newArray nbounds Nothing - completingN (f_idsf,f_idst) schedA tp - newmx | IM.null newinterface = 0 - | otherwise = fst $ IM.findMax newinterface - oldmx | IM.null sched = 0 - | otherwise = fst $ IM.findMax sched - newsched | newmx < oldmx = newinterface - | otherwise = sched - return $ (newmx < oldmx, newsched) - where addEdges - :: (Vertex, Vertex) - -> (IOArray Vertex Vertices, IOArray Vertex Vertices) - -> IO () - addEdges (f,t) (idsf,idst) = do - modifyArray idsf f (t `IS.insert`) - modifyArray idst t (f `IS.insert`) - --- | count the (max, avg, total) number of visits -getVisCount :: [Nt] -> InterfaceRes -> VisCount -getVisCount nts interfaces = - (mx, tot, (fromIntegral tot) / (fromIntegral $ length nts)) - where count (mx,tot) (Nt nt _ _ _ _ _) = (max mx k,tot + k) - where m = interfaces M.! nt - k | IM.null m = 0 - | otherwise = ((fst $ IM.findMax m) + 1) `div` 2 - (mx, tot) = foldl count (0,0) nts ---- minimisation functions -------------------------------------------------------------------------------- - -globalMinimum :: Sat -> Bool -> [MyVar] -> IO [MyVar] -globalMinimum sat des xs = - do ys <- sort sat xs - let mini (i,j) | i >= j = return [] - mini (i,j) = do putStrLn ("trying " ++ show (i,j)) - b <- satsolve sat [varnot (ys !! k)] - if b then mini (k+1,j) - else mini (i,k) - where - k = (i+j) `div` 2 - in mini (0,length ys) - xbs <- sequence [ do v <- value sat x - return (x,v) - | x <- xs - ] - return [ x | (x,Just True) <- xbs ] - where - sort sat [] = do return [] - sort sat [x] = do return [x] - sort sat xs = do as <- sort sat (take k xs) - bs <- sort sat (drop k xs) - map fromJust `fmap` merge (map Just as) (map Just bs) - where - k = length xs `div` 2 - - merge2 Nothing b = return (b, Nothing) - merge2 a Nothing = return (a, Nothing) - merge2 (Just x) (Just y) = - do a <- newLit sat - b <- newLit sat - addClause sat [varnot x, b] -- x => b - addClause sat [varnot y, b] -- y => b - addClause sat [varnot x, varnot y, a] -- x => ~y || a - addClause sat [x, varnot a] -- ~x => ~a - addClause sat [y, varnot a] -- ~y => ~a - addClause sat [x, y, varnot b] -- ~x => y || ~b - return (Just a,Just b) - - merge [] bs = return bs - merge as [] = return as - merge [a] [b] = (\(a,b) -> [a,b]) `fmap` merge2 a b - merge as bs = take (a+b) `fmap` merge' (as ++ xas) (bs ++ xbs) - where - a = length as - b = length bs - m = a `max` b - n = if even m then m else m+1 - xas = replicate (n-a) Nothing - xbs = replicate (n-b) Nothing - - -- pre: as and bs have the same, even length - merge' as bs = - do xs <- merge eas ebs - ys <- merge oas obs - let x:xys = weave xs ys - xys' <- sequence [ merge2 a b | (a,b) <- pairs xys ] - return (x : unpairs xys' ++ [last xys]) - where - (eas,oas) = evenOdds as - (ebs,obs) = evenOdds bs - - evenOdds [] = ([], []) - evenOdds [x] = ([x], []) - evenOdds (x:y:xs) = (x:es,y:os) - where - (es,os) = evenOdds xs - - pairs (x:y:xs) = (x,y) : pairs xs - pairs _ = [] - - unpairs ((x,y):xys) = x : y : unpairs xys - unpairs [] = [] - - weave (x:xs) (y:ys) = x : y : weave xs ys - weave xs ys = xs ++ ys - ------------------------------------------------------------------------------- + +module LOAG.Optimise where + +import LOAG.Common +import LOAG.Graphs +import LOAG.Solver.MiniSat + +import Control.Arrow ((&&&)) +import Control.Monad (forM, forM_, when, foldM) +import Control.Monad.ST +import Data.Array.MArray +import Data.Array.IO +import Data.Function (on) +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as M +import Data.Maybe (fromJust, isJust) +import Data.List (intercalate, sort, sortBy) + +type Opts = [Opt] +data Opt= Smaller (Vertex) (Vertex) -- x < y + | Greater (Vertex) (Vertex) -- x > y + | AllSmaller (Vertex) Direction -- _ < x + | AllGreater (Vertex) Direction -- _ > x + | MinVisits + deriving (Ord, Eq) + +instance Show Opt where + show (Smaller f t) = show f ++ " --> " ++ show t + show (Greater f t) = show f ++ " <-- " ++ show t + show (AllSmaller f _) = " _ --> " ++ show f + show (AllGreater f _) = " _ <-- " ++ show f + show MinVisits = " Minimising #visits " + + +optimise :: Sat -> VarMap -> Opts -> (Int,Int) -> [Nt] -> InterfaceRes -> IO () +optimise sat varMap opts nbounds nts interfaces = do + let scheduler = newSchedule sat varMap nbounds + mapM_ (singleOpt sat varMap scheduler nts interfaces) (sort opts) + b <- satsolve sat [] + return () + +-- | Given a non-terminal and a current best schedule +-- return a new best schedule and whether the new schedule is truely new +type SchedulerNt = Nt -> IM.IntMap [Vertex] -> IO (Bool, IM.IntMap [Vertex]) +type Scheduler = IM.IntMap [Vertex] -> IO (Bool, IM.IntMap [Vertex]) + +singleOpt :: Sat -> VarMap -> SchedulerNt -> [Nt] -> InterfaceRes -> Opt -> + IO () +singleOpt sat varMap scheduler nts interfaces opt = do + success <- + case opt of + Smaller f t -> tryPair sat $ varOf f t + Greater f t -> tryPair sat $ varOf t f + AllSmaller f d -> trySingle sat False f d varMap + AllGreater f d -> trySingle sat True f d varMap + MinVisits -> do mapM_ (minPaths sat varMap scheduler interfaces) $ + sortNfilter weigh nts + return True + return () + where weigh (Nt _ _ _ is ss _) = size + where size = length is + length ss + varOf f t = case M.lookup (f,t) varMap of + Just v -> v + Nothing -> case M.lookup (t,f) varMap of + Just v -> varnot v + Nothing -> error "invalid optimisation.." + +sortNfilter :: (a -> Int) -> [a] -> [a] +sortNfilter f = + map fst . sortBy (on compare snd) . + filter (((/=) 0) . snd) . map (id &&& f) + +minPaths :: Sat -> VarMap -> SchedulerNt -> InterfaceRes -> Nt -> IO Bool +minPaths sat varMap scheduler interfaces tp@(Nt nt _ _ is ss _) = do + forM_ neckCs $ attemptGroup sat (scheduler tp) mym . map varnot + return True + where neckCs= map (\(_,es,b) -> map (uncurry (mvar b)) es) $ + bottlenecks mx mym + mvar b f t | b = varMap M.! (f,t) + | not b = varnot $ varMap M.! (t,f) + mym = interfaces M.! nt + mx | IM.null mym = 0 + | otherwise = fst $ IM.findMax mym + +bottlenecks :: Int -> IM.IntMap [Vertex] -> + [(((Int,[Vertex]),(Int,[Vertex])),[Edge],Bool)] +bottlenecks x shd = + sortNfilter cost $ pairs x + where pairs x | x <= 1 = [] + | x > 1 = let pair = ((x,maybe [] id $ IM.lookup x shd) + ,(x-1,maybe [] id$IM.lookup (x-1) shd)) + in (pair,edges pair,even x) : pairs (x-1) + cost (((p1,p1s),(p2,p2s)),es,_) = size + where size = length es + edges ((p1,p1s),(p2,p2s)) = [ (f,t) | f <- p1s, t <- p2s ] + +-- | get all combinations of partitions from different `directions' +-- ordered by distance (shortest paths first) +edgeCombs :: Int -> IM.IntMap [Vertex] -> [(Int,Int)] +edgeCombs x shd = + sortBy (on compare cost) $ + concat $ + takeWhile (not . null) $ + map (\(n,es) -> filter ((>0) . snd) + (map (\(f,t) -> (f+n,t+n)) es)) $ + zip [-0,-1..] $ + repeat (map ((,) x) [x-1,x-3..1]) + where cost (x1,x2) = length $ findK (x1 -1) + where findK n | n < x2 = [] + | n >= x2 = (shd IM.! n) ++ findK (n-2) + +tryPair :: Sat -> MyVar -> IO Bool +tryPair sat p = do + b <- satsolve sat [p] + if b then addClause sat [p] + else return False + +attemptGroup :: Sat -> Scheduler -> IM.IntMap [Vertex] -> [MyVar] -> + IO (IM.IntMap [Vertex]) +attemptGroup sat scheduler interfaces = + tryGroup sat scheduler interfaces . filter notSet + where notSet (Var _) = True + notSet (VarNot v) = notSet v + notSet _ = False + +tryGroup :: Sat -> Scheduler -> IM.IntMap [Vertex] -> [MyVar] -> + IO (IM.IntMap [Vertex]) +tryGroup _ _ interfaces [] = return interfaces +tryGroup sat scheduler interfaces ps = do + xs <- mapM (const (newLit sat)) ps + mapM (\(a,r) -> addClause sat [varnot a, r]) $ zip xs ps + b <- satsolve sat xs + let success = assertVars sat xs + fail = assertVars sat (map varnot (xs++ps)) >> satsolve sat [] + if b then do (improved, sched) <- scheduler interfaces + if improved + then success >> return sched + else fail >> return interfaces + else fail >> return interfaces + +assertVars :: Sat -> [MyVar] -> IO () +assertVars sat vars = do bs <- mapM (addClause sat . (:[])) vars + return () + +trySingle :: Sat -> Bool -> Vertex -> Direction -> VarMap -> IO Bool +trySingle sat des f dir varMap = do + vars <- tryExtreme sat des literals + assertVars sat vars + return True + where literals = M.foldrWithKey select [] varMap + select k a b | fst k == f = a : b --inh + | snd k == f = varnot a : b --syn + | otherwise = b + +tryExtreme :: Sat -> Bool -> [MyVar] -> IO [MyVar] +tryExtreme sat des xs = + do a <- newLit sat + switch <- newLit sat + let try xs = + do --putStrLn ("currently, " ++ show (length xs) ++ " literals") + let assertOne | des = map varnot (a : xs) + | otherwise = varnot a : xs + addClause sat assertOne --"if a, then one of xs must be ~des" + b <- satsolve sat [a] + if b then + do xbs <- sequence [ do v <- value sat x + return (x,v) + | x <- xs + ] + sequence_ [ do let desx | des = x + | otherwise = varnot x + addClause sat [varnot a, desx] + addClause sat [varnot switch, desx] + | (x,b) <- xbs, b /= Just des ] + try [ x | (x,Just des) <- xbs ] + else do addClause sat [varnot a] + return [switch] + in try xs + +-- | Recalculate interface based on SAT and compare with a given one +newSchedule :: Sat -> VarMap -> (Int,Int) -> Nt -> IM.IntMap [Vertex] -> + IO (Bool, IM.IntMap [Vertex]) +newSchedule sat varMap nbounds tp@(Nt nt _ _ inhs outs _ ) sched = do + idsf <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices) + idst <- newArray nbounds IS.empty :: IO (IOArray Vertex Vertices) + let ids = (idsf,idst) + sequence_ [ do v <- value sat pred + case v of + Nothing -> error "no val" + Just True -> addEdges (i,s) ids + Just False-> addEdges (s,i) ids + | (i,ios,_) <- inhs + , (s,sos,_) <- outs + , let pred = varMap M.! (i,s) + ] + f_idsf <- freeze idsf + f_idst <- freeze idst + let (_,newinterface) = runST $ do schedA <- newArray nbounds Nothing + completingN (f_idsf,f_idst) schedA tp + newmx | IM.null newinterface = 0 + | otherwise = fst $ IM.findMax newinterface + oldmx | IM.null sched = 0 + | otherwise = fst $ IM.findMax sched + newsched | newmx < oldmx = newinterface + | otherwise = sched + return $ (newmx < oldmx, newsched) + where addEdges + :: (Vertex, Vertex) + -> (IOArray Vertex Vertices, IOArray Vertex Vertices) + -> IO () + addEdges (f,t) (idsf,idst) = do + modifyArray idsf f (t `IS.insert`) + modifyArray idst t (f `IS.insert`) + +-- | count the (max, avg, total) number of visits +getVisCount :: [Nt] -> InterfaceRes -> VisCount +getVisCount nts interfaces = + (mx, tot, (fromIntegral tot) / (fromIntegral $ length nts)) + where count (mx,tot) (Nt nt _ _ _ _ _) = (max mx k,tot + k) + where m = interfaces M.! nt + k | IM.null m = 0 + | otherwise = ((fst $ IM.findMax m) + 1) `div` 2 + (mx, tot) = foldl count (0,0) nts +--- minimisation functions +------------------------------------------------------------------------------- + +globalMinimum :: Sat -> Bool -> [MyVar] -> IO [MyVar] +globalMinimum sat des xs = + do ys <- sort sat xs + let mini (i,j) | i >= j = return [] + mini (i,j) = do putStrLn ("trying " ++ show (i,j)) + b <- satsolve sat [varnot (ys !! k)] + if b then mini (k+1,j) + else mini (i,k) + where + k = (i+j) `div` 2 + in mini (0,length ys) + xbs <- sequence [ do v <- value sat x + return (x,v) + | x <- xs + ] + return [ x | (x,Just True) <- xbs ] + where + sort sat [] = do return [] + sort sat [x] = do return [x] + sort sat xs = do as <- sort sat (take k xs) + bs <- sort sat (drop k xs) + map fromJust `fmap` merge (map Just as) (map Just bs) + where + k = length xs `div` 2 + + merge2 Nothing b = return (b, Nothing) + merge2 a Nothing = return (a, Nothing) + merge2 (Just x) (Just y) = + do a <- newLit sat + b <- newLit sat + addClause sat [varnot x, b] -- x => b + addClause sat [varnot y, b] -- y => b + addClause sat [varnot x, varnot y, a] -- x => ~y || a + addClause sat [x, varnot a] -- ~x => ~a + addClause sat [y, varnot a] -- ~y => ~a + addClause sat [x, y, varnot b] -- ~x => y || ~b + return (Just a,Just b) + + merge [] bs = return bs + merge as [] = return as + merge [a] [b] = (\(a,b) -> [a,b]) `fmap` merge2 a b + merge as bs = take (a+b) `fmap` merge' (as ++ xas) (bs ++ xbs) + where + a = length as + b = length bs + m = a `max` b + n = if even m then m else m+1 + xas = replicate (n-a) Nothing + xbs = replicate (n-b) Nothing + + -- pre: as and bs have the same, even length + merge' as bs = + do xs <- merge eas ebs + ys <- merge oas obs + let x:xys = weave xs ys + xys' <- sequence [ merge2 a b | (a,b) <- pairs xys ] + return (x : unpairs xys' ++ [last xys]) + where + (eas,oas) = evenOdds as + (ebs,obs) = evenOdds bs + + evenOdds [] = ([], []) + evenOdds [x] = ([x], []) + evenOdds (x:y:xs) = (x:es,y:os) + where + (es,os) = evenOdds xs + + pairs (x:y:xs) = (x,y) : pairs xs + pairs _ = [] + + unpairs ((x,y):xys) = x : y : unpairs xys + unpairs [] = [] + + weave (x:xs) (y:ys) = x : y : weave xs ys + weave xs ys = xs ++ ys + +------------------------------------------------------------------------------ diff --git a/src/LOAG/Solver/MiniSat.hs b/src/LOAG/Solver/MiniSat.hs --- a/src/LOAG/Solver/MiniSat.hs +++ b/src/LOAG/Solver/MiniSat.hs @@ -1,94 +1,94 @@ - -module LOAG.Solver.MiniSat ( - newSolvable,-- IO SatContainer - newLit, -- Sat -> IO MyVar - satValues, -- Sat -> IO (Int, Int) - addClause, -- Sat -> [MyVar] -> IO () - satsolve, -- Sat -> IO Bool - value, -- Sat -> IO (Maybe Bool) - fixed, -- Sat -> IO Bool - MyVar(..), - Sat, - varnot, - VarMap, - Mini.conflict - ) where - -import LOAG.Graphs -import Control.Monad -import Data.Maybe -import qualified Data.Map as M -import qualified MiniSat as Mini - -type Sat = Mini.Solver -type VarMap = M.Map Edge MyVar - -data MyVar = Var Mini.Lit - | VarTrue - | VarFalse - | VarNot MyVar - deriving (Show, Eq) - -varnot :: MyVar -> MyVar -varnot v@(Var i) = Var (Mini.neg i) -varnot (VarNot v)= v -varnot VarFalse = VarTrue -varnot VarTrue = VarFalse - - -newSolvable :: IO Mini.Solver -newSolvable = do sat <- Mini.newSolver - Mini.eliminate sat True - return sat - -newLit :: Sat -> IO MyVar -newLit sat = - do p <- Mini.newLit sat - return (Var (Mini.neg p)) - -satValues :: Sat -> IO (Int,Int) -satValues sat = - do v <- Mini.minisat_num_vars sat - p <- Mini.minisat_num_clauses sat - return (v,p) - -addClause :: Sat -> [MyVar] -> IO Bool -addClause sat [] = return True -addClause sat es = do - if satisfied - then return True - else case fes of - [] -> error "unsatisfiable" - fes -> Mini.addClause sat $ map toMini fes - where - satisfied = any (True ==?) es - fes = filter (not . (False ==?)) es - b ==? v = case v of - VarTrue -> b - VarFalse -> not b - _ -> False - toMini :: MyVar -> Mini.Lit - toMini (Var v) = v - toMini (VarNot v) = Mini.neg (toMini v) - _ = error "incorrect clause filtering" - -satsolve :: Sat -> [MyVar] -> IO Bool -satsolve sat = Mini.solve sat . map extract - -extract :: MyVar -> Mini.Lit -extract VarTrue = error "cannot extract True" -extract VarFalse = error "cannot extract False" -extract (VarNot v) = Mini.neg (extract v) -extract (Var l) = l - -value :: Sat -> MyVar -> IO (Maybe Bool) -value _ VarTrue = return $ Just True -value _ VarFalse = return $ Just False -value sat (VarNot v) = value sat v >>= return . fmap not -value sat (Var v) = Mini.modelValue sat v - -fixed :: Sat -> MyVar -> IO Bool -fixed _ VarTrue = return $ True -fixed _ VarFalse = return $ True -fixed sat (VarNot v)= fixed sat v -fixed sat (Var l) = Mini.value sat l >>= return . isJust + +module LOAG.Solver.MiniSat ( + newSolvable,-- IO SatContainer + newLit, -- Sat -> IO MyVar + satValues, -- Sat -> IO (Int, Int) + addClause, -- Sat -> [MyVar] -> IO () + satsolve, -- Sat -> IO Bool + value, -- Sat -> IO (Maybe Bool) + fixed, -- Sat -> IO Bool + MyVar(..), + Sat, + varnot, + VarMap, + Mini.conflict + ) where + +import LOAG.Graphs +import Control.Monad +import Data.Maybe +import qualified Data.Map as M +import qualified MiniSat as Mini + +type Sat = Mini.Solver +type VarMap = M.Map Edge MyVar + +data MyVar = Var Mini.Lit + | VarTrue + | VarFalse + | VarNot MyVar + deriving (Show, Eq) + +varnot :: MyVar -> MyVar +varnot v@(Var i) = Var (Mini.neg i) +varnot (VarNot v)= v +varnot VarFalse = VarTrue +varnot VarTrue = VarFalse + + +newSolvable :: IO Mini.Solver +newSolvable = do sat <- Mini.newSolver + Mini.eliminate sat True + return sat + +newLit :: Sat -> IO MyVar +newLit sat = + do p <- Mini.newLit sat + return (Var (Mini.neg p)) + +satValues :: Sat -> IO (Int,Int) +satValues sat = + do v <- Mini.minisat_num_vars sat + p <- Mini.minisat_num_clauses sat + return (v,p) + +addClause :: Sat -> [MyVar] -> IO Bool +addClause sat [] = return True +addClause sat es = do + if satisfied + then return True + else case fes of + [] -> error "unsatisfiable" + fes -> Mini.addClause sat $ map toMini fes + where + satisfied = any (True ==?) es + fes = filter (not . (False ==?)) es + b ==? v = case v of + VarTrue -> b + VarFalse -> not b + _ -> False + toMini :: MyVar -> Mini.Lit + toMini (Var v) = v + toMini (VarNot v) = Mini.neg (toMini v) + _ = error "incorrect clause filtering" + +satsolve :: Sat -> [MyVar] -> IO Bool +satsolve sat = Mini.solve sat . map extract + +extract :: MyVar -> Mini.Lit +extract VarTrue = error "cannot extract True" +extract VarFalse = error "cannot extract False" +extract (VarNot v) = Mini.neg (extract v) +extract (Var l) = l + +value :: Sat -> MyVar -> IO (Maybe Bool) +value _ VarTrue = return $ Just True +value _ VarFalse = return $ Just False +value sat (VarNot v) = value sat v >>= return . fmap not +value sat (Var v) = Mini.modelValue sat v + +fixed :: Sat -> MyVar -> IO Bool +fixed _ VarTrue = return $ True +fixed _ VarFalse = return $ True +fixed sat (VarNot v)= fixed sat v +fixed sat (Var l) = Mini.value sat l >>= return . isJust diff --git a/src/MirageSyntax.hs b/src/MirageSyntax.hs new file mode 100644 --- /dev/null +++ b/src/MirageSyntax.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveGeneric #-} + +module MirageSyntax where + +import Data.Aeson (ToJSON) +import GHC.Generics (Generic) + +data Grammar = Grammar [Nonterminal] deriving Generic + +instance ToJSON Grammar + +data Nonterminal = Nonterminal + String -- ^ The name of this nonterminal. + [String] -- ^ The names of the parameters. + [Attribute] -- ^ The inherited attributes. + [Attribute] -- ^ The synthesized attributes. + [Production] -- ^ The production rules with this nonterminal on the left hand side. + deriving Generic + +instance ToJSON Nonterminal + +data Attribute = Attribute + String -- ^ The name of this attribute. + Type -- ^ The type of this attribute. + deriving Generic + +instance ToJSON Attribute + +data Production = Production + String -- ^ The name of this production rule. + [Child] -- ^ The children of this rule; the right hand side. + [Rule] -- ^ The attribute rules of this production. + deriving Generic + +instance ToJSON Production + +data Child = Child + String -- ^ The name of this child. + Type -- ^ The type of this child. + deriving Generic + +instance ToJSON Child + +data Rule = Rule + [Address] -- ^ Targets of this rule; the left hand side. + [Address] -- ^ Sources of this rule; the right hand side. + Bool -- ^ Whether this rule is defined explicitly by the user. + String -- ^ The origin of this rule; which source file contains this rule? + String -- ^ A pretty printed representation of this rule. + deriving Generic + +instance ToJSON Rule + +data Type + = Haskell String -- ^ A plain Haskell type. + | NT -- ^ An attribute grammar nonterminal + String -- ^ The name of the nonterminal + [String] -- ^ The arguments of this nonterminal; must always be plain Haskell values. + | Self -- ^ Refers to the nonterminal in which this type is used. + deriving Generic + +instance ToJSON Type + +data Address = Address + String -- ^ The part before the dot: 'lhs', 'loc', or the name of a child. + String -- ^ The attribute name + deriving Generic + +instance ToJSON Address + diff --git a/src/PPUtil.hs b/src/PPUtil.hs --- a/src/PPUtil.hs +++ b/src/PPUtil.hs @@ -1,59 +1,59 @@ -module PPUtil where - --- --- Some additional pretty-print functions --- for pretty-printing abstract syntax trees. --- - -import Data.List -import qualified Data.Map as Map -import Pretty -import Options - -ppListSep :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc -ppListSep o c s pps = o >|< hlist (intersperse (pp s) (map pp pps)) >|< c - -ppSpaced :: PP a => [a] -> PP_Doc -ppSpaced = ppListSep "" "" " " - -ppCommas :: PP a => [a] -> PP_Doc -ppCommas = ppListSep "" "" ", " - -ppVList :: PP a => [a] -> PP_Doc -ppVList [] = "[" >#< "]" -ppVList (x:xs) = vlist (("[" >#< pp x) : (map (\y -> "," >#< pp y) xs)) >#< "]" - -ppMap :: (Show a, Show b) => Map.Map a b -> PP_Doc -ppMap m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- Map.toList m ] - -ppAssocL :: (Show a, Show b) => [(a,b)] -> PP_Doc -ppAssocL m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- m ] - -ppF :: String -> PP_Doc -> PP_Doc -ppF s x = s >|< ":" >#< x - -ppNest :: PP a => [a] -> [PP_Doc] -> [PP_Doc] -> PP_Doc -ppNest nms attrs ps = ppNestInfo {- defaultEHCOpts -} nms attrs ps [] - -ppNestInfo :: PP a => {- EHCOpts -> -} [a] -> [PP_Doc] -> [PP_Doc] -> [(String,PP_Doc)] -> PP_Doc -ppNestInfo {- opts -} nms attrs ps infos - = ppListSep "" "" "_" nms - >#< ( (if null attrs then empty else ppSpaced attrs) - >-< (if False {- ehcOptDebug opts -} then vlist (map (\(i,p) -> pp i >|< ":" >#< p) infos) else empty) - ) - >-< indent 2 (vlist ps) - -ppNm :: String -> PP_Doc -ppNm = text . show - -ppShow :: Show x => x -> PP_Doc -ppShow x = pp $ show x - -mkInfo1 :: String -> PP_Doc -> (String,PP_Doc) -mkInfo1 = (,) - -ppLinePragma :: Options -> Int -> String -> PP_Doc -ppLinePragma opts ln fl - | ocaml opts = "#" >#< show ln >#< show fl - | clean opts = "//" >#< show ln >#< show fl - | otherwise = "{-# LINE" >#< show ln >#< show fl >#< "#-}" +module PPUtil where + +-- +-- Some additional pretty-print functions +-- for pretty-printing abstract syntax trees. +-- + +import Data.List +import qualified Data.Map as Map +import Pretty +import Options + +ppListSep :: (PP s, PP c, PP o, PP a) => o -> c -> s -> [a] -> PP_Doc +ppListSep o c s pps = o >|< hlist (intersperse (pp s) (map pp pps)) >|< c + +ppSpaced :: PP a => [a] -> PP_Doc +ppSpaced = ppListSep "" "" " " + +ppCommas :: PP a => [a] -> PP_Doc +ppCommas = ppListSep "" "" ", " + +ppVList :: PP a => [a] -> PP_Doc +ppVList [] = "[" >#< "]" +ppVList (x:xs) = vlist (("[" >#< pp x) : (map (\y -> "," >#< pp y) xs)) >#< "]" + +ppMap :: (Show a, Show b) => Map.Map a b -> PP_Doc +ppMap m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- Map.toList m ] + +ppAssocL :: (Show a, Show b) => [(a,b)] -> PP_Doc +ppAssocL m = ppVList [ ppF (show k) $ ppShow v | (k,v) <- m ] + +ppF :: String -> PP_Doc -> PP_Doc +ppF s x = s >|< ":" >#< x + +ppNest :: PP a => [a] -> [PP_Doc] -> [PP_Doc] -> PP_Doc +ppNest nms attrs ps = ppNestInfo {- defaultEHCOpts -} nms attrs ps [] + +ppNestInfo :: PP a => {- EHCOpts -> -} [a] -> [PP_Doc] -> [PP_Doc] -> [(String,PP_Doc)] -> PP_Doc +ppNestInfo {- opts -} nms attrs ps infos + = ppListSep "" "" "_" nms + >#< ( (if null attrs then empty else ppSpaced attrs) + >-< (if False {- ehcOptDebug opts -} then vlist (map (\(i,p) -> pp i >|< ":" >#< p) infos) else empty) + ) + >-< indent 2 (vlist ps) + +ppNm :: String -> PP_Doc +ppNm = text . show + +ppShow :: Show x => x -> PP_Doc +ppShow x = pp $ show x + +mkInfo1 :: String -> PP_Doc -> (String,PP_Doc) +mkInfo1 = (,) + +ppLinePragma :: Options -> Int -> String -> PP_Doc +ppLinePragma opts ln fl + | ocaml opts = "#" >#< show ln >#< show fl + | clean opts = "//" >#< show ln >#< show fl + | otherwise = "{-# LINE" >#< show ln >#< show fl >#< "#-}" diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,613 +1,613 @@ -module Parser -where -import Data.Maybe -import UU.Parsing -import UU.Parsing.Machine(RealParser(..),RealRecogn(..),anaDynE,mkPR) -import ConcreteSyntax -import CommonTypes -import Patterns -import UU.Pretty(text,PP_Doc,empty,(>-<)) -import TokenDef -import Data.List (intersperse) -import Data.Char -import Scanner (Input(..),scanLit,input) -import System.FilePath -import Data.List -import Expression -import Macro --marcos -import UU.Scanner.Token -import UU.Scanner.TokenParser -import UU.Scanner.GenToken -import UU.Scanner.GenTokenOrd -import UU.Scanner.GenTokenParser -import UU.Scanner.Position -import UU.Scanner.TokenShow() -import System.Directory -import System.FilePath -import HsTokenScanner -import Options -import Scanner(lowercaseKeywords) - - -type AGParser = AnaParser Input Pair Token Pos - -pIdentifier, pIdentifierU, pIdentifierExcl :: AGParser Identifier -pIdentifierU = uncurry Ident <$> pConidPos - --- Jeroen (3-10-2012): for some reason using pKeywordAsIdent --- drastically slows down parsing of some of my AG files, as --- in: I thought there was some infinite loop in there, but I --- guess that eventually it could have given an answer. So --- probably this does generate a lot of ambiguity. -pIdentifier = pIdentifierExcl -- <|> pKeywordAsIdent -pIdentifierExcl = uncurry Ident <$> pVaridPos - --- see Scanner.lowercaseKeywords for the list of keywords that may --- be used as an identifier. To prevent ambiguities, it's probably --- sufficient when the keyword is always followed by a token that --- can never follow an identifier for any possible prefix. -pKeywordAsIdent :: AGParser Identifier -pKeywordAsIdent = pAny (\nm -> Ident nm <$> pKeyPos nm) lowercaseKeywords - -parseAG :: Options -> [FilePath] -> String -> IO (AG,[Message Token Pos]) -parseAG opts searchPath file = do - (es,_,_,_,mesg) <- parseFile False opts searchPath file - return (AG es, mesg) - ---marcos -parseAGI :: Options -> [FilePath] -> String -> IO (AG, Maybe String) -parseAGI opts searchPath file - = do (es,_,_,ext,_) <- parseFile True opts searchPath file - return (AG es, ext) - - -depsAG :: Options -> [FilePath] -> String -> IO ([String], [Message Token Pos]) -depsAG opts searchPath file - = do let fn = normalise file - (_,_,fs,_,mesgs) <- parseFile False opts searchPath fn - return (filter (/= fn) fs, mesgs) - --- marcos: added the parameter 'agi' and the 'ext' part -parseFile :: Bool -> Options -> [FilePath] -> String -> IO ([Elem],[String],[String], Maybe String,[Message Token Pos ]) -parseFile = parseFile' [] - -parseFile' :: [String] -> Bool -> Options -> [FilePath] -> String -> IO ([Elem],[String],[String], Maybe String,[Message Token Pos ]) -parseFile' parsedfiles agi opts searchPath filename - = do file <- normalise `fmap` resolveFile opts searchPath filename - if file `elem` parsedfiles - then return ([], [], parsedfiles, Nothing, []) - else do - txt <- readFile file - let searchPath' = takeDirectory file : searchPath -- search first relative to the including file - litMode = ".lag" `isSuffixOf` file - (files,text) = if litMode then scanLit txt - else ([],txt) - tokens = input opts (initPos file) text - - steps = parse (pElemsFiles agi) tokens - stop (_,fs,_,_,_) = null fs - cont (es,f:fs,allfs,ext,msg) - = do (ess,fss,allfss,_, msgs) <- parseFile' allfs agi opts searchPath' f - return (ess ++ es, fss ++ fs, allfss, ext, msg ++ msgs) - let (Pair (es,fls,ext) _ ,mesg) = evalStepsMessages steps - loopp stop cont (es,files ++ fls,file : parsedfiles, ext,mesg) - where - - -- - -- Option dependent AG Parsers inlined here - -- to have access to the opts - -- while retaining sharing - -- - - pElemsFiles :: Bool -> AGParser ([Elem],[String],Maybe String) - pElemsFiles agi = pFoldr (($),([],[],Nothing)) pElem' - where pElem' = addElem <$> pElem - <|> pINCLUDE *> (addInc <$> pStringPos) - <|> pEXTENDS *> (addExt <$> pStringPos) - addElem e (es,fs,ext) = (e:es, fs, ext) - addInc (fn,_) (es,fs,ext) - | noIncludes opts = (es, fs, ext) -- skip includes - | otherwise = (es,normalise fn:fs, ext) - addExt (fn,_) (es,fs,ext) - | noIncludes opts = (es, fs, ext) -- skip includes - | otherwise = if agi then (es,fs, Just fn') else (es,fn':fs, ext) --marcos - where fn' = normalise fn - - pCodescrapL = (\(ValToken _ str pos) -> (str, pos))<$> - parseScrapL "a code block" - - parseScrapL :: AGParser Token - parseScrapL - = let p acc = (\k (Input pos str next) -> - let (sc,rest) = case next of - Just (t@(ValToken TkTextln _ _), rs) -> (t,rs) - _ -> let (tok,p2,inp2) = codescrapL pos str - in (tok, input opts p2 inp2) - steps = k ( rest) - in (val (acc sc) steps) - ) - in anaDynE (mkPR (P (p ), R (p (const id)))) - - pElems :: AGParser Elems - pElems = pList_ng pElem - - pComplexType = List <$> pBracks pTypeEncapsulated - <|> Maybe <$ pMAYBE <*> pType - <|> Either <$ pEITHER <*> pType <*> pType - <|> Map <$ pMAP <*> pTypePrimitive <*> pType - <|> IntMap <$ pINTMAP <*> pType - <|> OrdSet <$ pSET <*> pType - <|> IntSet <$ pINTSET - <|> tuple <$> pParens (pListSep pComma field) - where field = (,) <$> ((Just <$> pIdentifier <* pTypeColon) `opt` Nothing) <*> pTypeEncapsulated - tuple xs = Tuple [(fromMaybe (Ident ("x"++show n) noPos) f, t) - | (n,(f,t)) <- zip [1..] xs - ] - - pOptClassContext' :: AGParser ClassContext - pOptClassContext' - | ocaml opts = pSucceed [] - | otherwise = pOptClassContext - - pTyVars :: AGParser [Identifier] - pTyVars - | ocaml opts = return <$> pTypeVar - <|> pSucceed [] - <|> pParens (pListSep pComma pTypeVar) - | otherwise = pList pIdentifier - - pElem :: AGParser Elem - pElem - = (\(pos, ct) -> Data pos ct) - <$> ( (\x -> (x, DataConstructor)) <$> (pDATA <|> pTYPE) - <|> (\x -> (x, RecordConstructor)) <$> pRECORD - ) - <*> pOptClassContext' - <*> pNontSet - <*> pTyVars - <*> pOptAttrs - <*> pAlts - <*> pSucceed False - <|> Attr <$> pATTR - <*> pOptClassContext' - <*> pNontSet - <*> pOptQuantifiers - <*> pAttrs - <|> Type <$> pTYPE - <*> pOptClassContext' - <*> pTypeCon - <*> pTyVars - <* pEquals - <*> pComplexType - <|> Sem <$> pSEM - <*> pOptClassContext' - <*> pNontSet - <*> pOptAttrs - <*> pOptQuantifiers - <*> pSemAlts - <|> Set <$> pSET - <*> pTypeCon - <*> ( False <$ pEquals - <|> True <$ pColon - ) - <*> pNontSet - <|> Deriving - <$> pDERIVING - <*> pNontSet - <* pColon - <*> pListSep pComma pIdentifierU - <|> Wrapper - <$> pWRAPPER - <*> pNontSet - <|> Nocatas - <$> pNOCATAS - <*> pNontSet - <|> Pragma - <$> pPRAGMA - <*> pList1 pIdentifier - <|> Module - <$> pMODULE - <*> pCodescrap' - <*> pCodescrap' - <*> pCodescrap' - <|> codeBlock <$> pBlockKind <*> ((Just <$ pATTACH <*> pTypeCon) <|> pSucceed Nothing) <*> pCodeBlock "a statement" - where codeBlock knd mbNt (txt,pos) = Txt pos knd mbNt (lines txt) - - pBlockKind :: AGParser BlockKind - pBlockKind = - BlockPragma <$ pOPTPRAGMAS - <|> BlockImport <$ pIMPORTS - <|> BlockMain <$ pTOPLEVEL -- block is moved to the toplevel ("main") module when "sepsemmods" is used - <|> BlockData <$ pDATABLOCK - <|> BlockRec <$ pRECBLOCK - <|> pSucceed BlockOther - - pAttrs :: AGParser Attrs - pAttrs - = Attrs <$> pOBrackPos <*> (concat <$> pList pInhAttrNames "inherited attribute declarations") - <* pBar <*> (concat <$> pList pAttrNames "chained attribute declarations" ) - <* pBar <*> (concat <$> pList pAttrNames "synthesised attribute declarations" ) - <* pCBrack - <|> (\ds -> Attrs (fst $ head ds) [n | (_,(nms,_,_)) <- ds, n <- nms] [n | (_,(_,nms,_)) <- ds, n <- nms] [n | (_,(_,_,nms)) <- ds, n <- nms]) <$> pList1 pSingleAttrDefs - - pSingleAttrDefs :: AGParser (Pos, (AttrNames, AttrNames, AttrNames)) - pSingleAttrDefs - = (\p is -> (p, (is,[],[]))) <$> pINH <*> pList1Sep pComma pSingleInhAttrDef - <|> (\p is -> (p, ([],[],is))) <$> pSYN <*> pList1Sep pComma pSingleSynAttrDef - <|> (\p is -> (p, ([],is,[]))) <$> pCHN <*> pList1Sep pComma pSingleChnAttrDef - - pSingleInhAttrDef :: AGParser (Identifier,Type,(String,String,String)) - pSingleInhAttrDef - = (\v tp -> (v,tp,("","",""))) <$> pAttrIdentifier <* pTypeColon <*> pTypeOrSelf "inh attribute declaration" - - pSingleSynAttrDef :: AGParser (Identifier,Type,(String,String,String)) - pSingleSynAttrDef - = (\v u tp -> (v,tp,u)) <$> pAttrIdentifier <*> pUse <* pTypeColon <*> pTypeOrSelf "syn attribute declaration" - - pSingleChnAttrDef :: AGParser (Identifier,Type,(String,String,String)) - pSingleChnAttrDef - = (\v tp -> (v,tp,("","",""))) <$> pAttrIdentifier <* pTypeColon <*> pTypeOrSelf "chn attribute declaration" - - pOptAttrs :: AGParser Attrs - pOptAttrs = pAttrs `opt` Attrs noPos [] [] [] - - pInhAttrNames :: AGParser AttrNames - pInhAttrNames - = (\vs tp -> map (\v -> (v,tp,("","",""))) vs) - <$> pAttrIdentifiers <* pTypeColon <*> pTypeOrSelf "attribute declarations" - - pAttrNames :: AGParser AttrNames - pAttrNames - = (\vs use tp -> map (\v -> (v,tp,use)) vs) - <$> pAttrIdentifiers <*> pUse <* pTypeColon <*> pTypeOrSelf "attribute declarations" - - pAlt :: AGParser Alt - pAlt = (Alt <$> pBar <*> pSimpleConstructorSet <*> (pList1_ng pTypeVar <* pDot <|> pSucceed []) <*> pFields <*> pMaybeMacro "a datatype alternative") - - pAlts :: AGParser Alts - pAlts = pList_ng pAlt "datatype alternatives" - - pFields :: AGParser Fields - pFields = concat <$> pList_ng pField "fields" - - pField :: AGParser Fields - pField - = (\nms tp -> map (\nm -> FChild nm tp) nms) <$> pAttrIdentifiers <* pTypeColon <*> pType - <|> (\s -> [FChild (Ident (mklower $ getName s) (getPos s)) (NT s [] False)]) <$> pIdentifierU - <|> (\t -> [FCtx [t]]) <$ pSmallerEqual <*> pTypePrimitive - - pSemAlt :: AGParser SemAlt - pSemAlt = SemAlt <$> pBar <*> pConstructorSet <*> pSemDefs "SEM alternative" - - pSemAlts :: AGParser SemAlts - pSemAlts = pList pSemAlt "SEM alternatives" - - pSemDef :: AGParser [SemDef] - pSemDef - = (\x y fs -> map (\f -> f x y) fs) <$> pMaybeRuleName <*> pFieldIdentifier <*> pList1 pAttrDef - <|> pLOC *> pList1 pLocDecl - <|> pINST *> pList1 pInstDecl - <|> pSEMPRAGMA *> pList1 (SemPragma <$> pNames) - <|> (\n e -> [AugmentDef n e]) <$ pAugmentToken <*> pAttrIdentifier <* pAssign <*> pExpr - <|> (\n e -> [AroundDef n e]) <$ pAROUND <*> pAttrIdentifier <* pAssign <*> pExpr - <|> (\a b -> [AttrOrderBefore a [b]]) <$> pList1 pAttrOrIdent <* pSmaller <*> pAttrOrIdent - <|> (\sources target nt expr -> [MergeDef target nt sources expr]) <$ pMERGE <*> (pList1_ng pIdentifier <* pAS <|> pSucceed []) <*> pIdentifier <* pTypeColon <*> pIdentifierU <* pAssign <*> pExpr - <|> (\mbNm pat (owrt,pos,pur,eager) exp -> [Def pos mbNm (pat ()) exp owrt pur eager]) <$> pMaybeRuleName <*> pPattern (const <$> pAttr) <*> pRuleSym <*> pExpr - - pMaybeRuleName :: AGParser (Maybe Identifier) - pMaybeRuleName - = (Just <$> pIdentifier <* pColon "rule name") - <|> pSucceed Nothing - - pAttrDef :: AGParser (Maybe Identifier -> Identifier -> SemDef) - pAttrDef - = (\pat (owrt,pos,pur,eager) exp mbNm fld -> Def pos mbNm (pat fld) exp owrt pur eager) - <$ pDot <*> pattern <*> pRuleSym <*> pExpr - where pattern = pPattern pVar - <|> (\ir a fld -> ir $ Alias fld a (Underscore noPos)) <$> ((Irrefutable <$ pTilde) `opt` id) <*> pAttrIdentifier - - pLocDecl :: AGParser SemDef - pLocDecl = pDot <**> (pIdentifier <**> (pTypeColon <**> ( (\(tp,pos) _ ident _ -> TypeDef pos ident tp) <$> pLocType - <|> (\ref _ ident _ -> UniqueDef ident ref) <$ pUNIQUEREF <*> pIdentifier ))) - - pLocType :: AGParser (Type, Pos) - pLocType = (\u -> (Haskell $ getName u, getPos u)) <$> pTypeCon - <|> (\(s,p) -> (Haskell s,p)) <$> pCodescrap "a type" - - pInstDecl :: AGParser SemDef - pInstDecl = (\ident tp -> TypeDef (getPos ident) ident tp) - <$ pDot <*> pIdentifier <* pTypeColon <*> pTypeNt - - pSemDefs :: AGParser SemDefs - pSemDefs = concat <$> pList_ng pSemDef "attribute rules" - - pExpr :: AGParser Expression - pExpr = (\(str,pos) -> Expression pos (lexTokens opts pos str)) <$> pCodescrapL "an expression" - - pTypeColon :: AGParser Pos - pTypeColon - = if doubleColons opts - then pDoubleColon - else pColon - - --marcos - pMaybeMacro :: AGParser MaybeMacro - pMaybeMacro = Just <$ pDoubleArrow <*> pMacro - <|> pSucceed Nothing - - pMacro :: AGParser Macro - pMacro - = Macro <$> pIdentifierU - <*> pList1 pMacroChild - "macro" - - pMacroChild :: AGParser MacroChild - pMacroChild - = (pIdentifier <* pEquals) <**> - (flip RuleChild <$> pMacro <|> - flip ChildChild <$> pIdentifier <|> - flip ValueChild <$> pCodescrap' ) - - pTypeNt :: AGParser Type - pTypeNt - = ((\nt -> mkNtType nt []) <$> pTypeCon "nonterminal name (no brackets)") - <|> (pParens (mkNtType <$> pTypeCon <*> pList pTypeHaskellAnyAsString) "nonterminal name with parameters (using parenthesis)") - - pTypeCon :: AGParser Identifier - pTypeCon - | ocaml opts = pIdentifierExcl - | otherwise = pIdentifierU - - pTypeVar :: AGParser Identifier - pTypeVar - | ocaml opts = (\(nm, pos) -> Ident nm pos) <$> pTextnmPos - | otherwise = pIdentifier - - pTypeHaskellAnyAsString :: AGParser String - pTypeHaskellAnyAsString - = getName <$> pTypeVar - <|> getName <$> pTypeCon - <|> pCodescrap' "a type" - - -- if the type is within some kind of parentheses or brackets (then we allow lowercase identifiers as well) - pTypeEncapsulated :: AGParser Type - pTypeEncapsulated - = pParens pTypeEncapsulated - <|> mkNtType <$> pTypeCon <*> pList pTypeHaskellAnyAsString - <|> (Haskell . getName) <$> pTypeVar - <|> pTypePrimitive - - pTypePrimitive :: AGParser Type - pTypePrimitive - = Haskell <$> pCodescrap' "a type" - - pType :: AGParser Type - pType = pTypeNt - <|> pTypePrimitive - - pTypeOrSelf :: AGParser Type - pTypeOrSelf = pType <|> Self <$ pSELF - - pOptClassContext :: AGParser ClassContext - pOptClassContext - = pClassContext <* pDoubleArrow - <|> pSucceed [] - - pClassContext :: AGParser ClassContext - pClassContext - = pListSep pComma ((,) <$> pIdentifierU <*> pList pTypeHaskellAnyAsString) - - pNontSet = set0 where - set0 = pChainr (Intersect <$ pIntersect) set1 - set1 = pChainl (Difference <$ pMinus) set2 - set2 = pChainr (pSucceed Union) set3 - set3 = pTypeCon <**> opt (flip Path <$ pArrow <*> pTypeCon) NamedSet - <|> All <$ pStar - <|> pParens set0 - - -- - -- End of AG Parser - -- - -resolveFile :: Options -> [FilePath] -> FilePath -> IO FilePath -resolveFile opts path fname = search (path ++ ["."]) - where search (p:ps) = do let filename = joinPath [p, fname] - fExists <- doesFileExist filename - if fExists - then return filename - else do let filename' = joinPath [p, replaceExtension fname "ag"] - fExists' <- doesFileExist filename' - if fExists' - then return filename' - else search ps - search [] = do - outputStr opts ("File: " ++ show fname ++ " not found in search path: " ++ show (concat (intersperse ";" (path ++ ["."]))) ++ "\n") - failWithCode opts 1 - return (error "resolveFile: file not found") - -evalStepsMessages :: (Eq s, Show s, Show p) => Steps a s p -> (a,[Message s p]) -evalStepsMessages steps = case steps of - OkVal v rest -> let (arg,ms) = evalStepsMessages rest - in (v arg,ms) - Ok rest -> evalStepsMessages rest - Cost _ rest -> evalStepsMessages rest - StRepair _ msg rest -> let (v,ms) = evalStepsMessages rest - in (v, msg:ms) - Best _ rest _ -> evalStepsMessages rest - NoMoreSteps v -> (v,[]) - -loopp ::(a->Bool) -> (a->IO a) -> a -> IO a -loopp pred cont x | pred x = return x - | otherwise = do x' <- cont x - loopp pred cont x' - -codescrapL p [] = (valueToken TkTextln "" p,p,[]) -codescrapL p (x:xs) | isSpace x = (updPos' x p) codescrapL xs - | otherwise = let refcol = column p - (p',sc,rest) = scrapL refcol p (x:xs) - in (valueToken TkTextln sc p,p',rest) - -scrapL ref p (x:xs) | isSpace x || column p >= ref = - let (p'',sc,inp) = updPos' x p (scrapL ref) xs - in (p'',x:sc,inp) - | otherwise =(p,[],x:xs) -scrapL ref p [] = (p,[],[]) - -pNames :: AGParser [Identifier] -pNames = pIdentifiers - - --- Insertion is expensive for pCodeBlock in order to prevent infinite inserts. -pCodeBlock :: AGParser (String,Pos) -pCodeBlock = pCostValToken 90 TkTextln "" "a code block" - -pOptQuantifiers :: AGParser [String] -pOptQuantifiers = (return <$ pDoubleColon <*> pCodescrap') `opt` [] - -pIdentifiers :: AGParser [Identifier] -pIdentifiers = pList1Sep pComma pIdentifier "lowercase identifiers" - -pAttrIdentifier :: AGParser Identifier -pAttrIdentifier = pIdentifier - <|> (\pos -> Ident "imports" pos) <$> pIMPORTS - <|> (\pos -> Ident "toplevel" pos) <$> pTOPLEVEL - -pAttrIdentifiers :: AGParser [Identifier] -pAttrIdentifiers = pList1Sep pComma pAttrIdentifier "lowercase identifiers" - -pUse :: AGParser (String,String,String) -pUse = ( (\u x y->(x,y,show u)) <$> pUSE <*> pCodescrap' <*> pCodescrap') `opt` ("","","") "USE declaration" - -mklower :: String -> String -mklower (x:xs) = toLower x : xs -mklower [] = [] - -pSimpleConstructorSet :: AGParser ConstructorSet -pSimpleConstructorSet = CName <$> pIdentifierU - <|> CAll <$ pStar - <|> pParens pConstructorSet - -pConstructorSet :: AGParser ConstructorSet -pConstructorSet = pChainl (CDifference <$ pMinus) term2 - where term2 = pChainr (pSucceed CUnion) term1 - term1 = CName <$> pIdentifierU - <|> CAll <$ pStar - -pFieldIdentifier :: AGParser Identifier -pFieldIdentifier = pIdentifier - <|> Ident "lhs" <$> pLHS - <|> Ident "loc" <$> pLOC - <|> Ident "inst" <$> pINST - -pAugmentToken :: AGParser () -pAugmentToken = () <$ (pAUGMENT <|> pPlus) - -pAttr = (,) <$> pFieldIdentifier <* pDot <*> pAttrIdentifier - -pAttrOrIdent - = OccAttr <$> pFieldIdentifier <* pDot <*> pAttrIdentifier - <|> OccRule <$> pIdentifier - -nl2sp :: Char -> Char -nl2sp '\n' = ' ' -nl2sp '\r' = ' ' -nl2sp x = x - -pVar :: AGParser (Identifier -> (Identifier, Identifier)) -pVar = (\att fld -> (fld,att)) <$> pAttrIdentifier - -pAssign :: AGParser Bool -pAssign = False <$ pReserved "=" - <|> True <$ pReserved ":=" - -pRuleSym :: AGParser (Bool, Pos, Bool, Bool) -pRuleSym = (\p -> (False, p, True, False)) <$> pReserved "=" - <|> (\p -> (True, p, True, False)) <$> pReserved ":=" - <|> (\p -> (False, p, True, False)) <$> pReserved "<-" - <|> (\p -> (False, p, True, True)) <$> pReserved "<<-" - -pPattern :: AGParser (a -> (Identifier,Identifier)) -> AGParser (a -> Pattern) -pPattern pvar = pPattern2 where - pPattern0 = (\i pats a -> Constr i (map ($ a) pats)) - <$> pIdentifierU <*> pList pPattern1 - <|> pPattern1 "a pattern" - pPattern1 = pvariable - <|> pPattern2 - pvariable = (\ir var pat a -> case var a of (fld,att) -> ir $ Alias fld att (pat a)) - <$> ((Irrefutable <$ pTilde) `opt` id) <*> pvar <*> ((pAt *> pPattern1) `opt` const (Underscore noPos)) - pPattern2 = (mkTuple <$> pOParenPos <*> pListSep pComma pPattern0 <* pCParen ) - <|> (const . Underscore) <$> pUScore "a pattern" - where mkTuple _ [x] a = x a - mkTuple p xs a = Product p (map ($ a) xs) - -pCostSym' c t = pCostSym c t t - -pCodescrap' :: AGParser String -pCodescrap' = fst <$> pCodescrap - -pCodescrap :: AGParser (String,Pos) -pCodescrap = pCodeBlock - -pSEM, pATTR, pDATA, pRECORD, pUSE, pLOC,pINCLUDE, pTYPE, pEquals, pColonEquals, pTilde, - pEXTENDS, --marcos - pBar, pColon, pLHS,pINST,pSET,pDERIVING,pMinus,pIntersect,pDoubleArrow,pArrow, - pDot, pUScore, pEXT,pAt,pStar, pSmaller, pWRAPPER, pNOCATAS, pPRAGMA, pMAYBE, pEITHER, pMAP, pINTMAP, - pMODULE, pATTACH, pUNIQUEREF, pINH, pSYN, pAUGMENT, pPlus, pAROUND, pSEMPRAGMA, pMERGE, pAS, pSELF, - pIMPORTS, pOPTPRAGMAS, pSmallerEqual, pINTSET, pDATABLOCK, pRECBLOCK - :: AGParser Pos -pSET = pCostReserved 90 "SET" "SET" -pDERIVING = pCostReserved 90 "DERIVING" "DERIVING" -pWRAPPER = pCostReserved 90 "WRAPPER" "WRAPPER" -pNOCATAS = pCostReserved 90 "NOCATAS" "NOCATAS" -pPRAGMA = pCostReserved 90 "PRAGMA" "PRAGMA" -pSEMPRAGMA = pCostReserved 90 "SEMPRAGMA" "SEMPRAGMA" -pATTACH = pCostReserved 90 "ATTACH" "ATTACH" -pDATA = pCostReserved 90 "DATA" "DATA" -pRECORD = pCostReserved 90 "RECORD" "RECORD" -pEXT = pCostReserved 90 "EXT" "EXT" -pATTR = pCostReserved 90 "ATTR" "ATTR" -pSEM = pCostReserved 90 "SEM" "SEM" -pINCLUDE = pCostReserved 90 "INCLUDE" "INCLUDE" -pEXTENDS = pCostReserved 90 "EXTENDS" "EXTENDS" --marcos -pTYPE = pCostReserved 90 "TYPE" "TYPE" -pINH = pCostReserved 90 "INH" "INH" -pSYN = pCostReserved 90 "SYN" "SYN" -pCHN = pCostReserved 90 "CHN" "CHN" -pMAYBE = pCostReserved 5 "MAYBE" "MAYBE" -pEITHER = pCostReserved 5 "EITHER" "EITHER" -pMAP = pCostReserved 5 "MAP" "MAP" -pINTMAP = pCostReserved 5 "INTMAP" "INTMAP" -pINTSET = pCostReserved 5 "INTSET" "INTSET" -pUSE = pCostReserved 5 "USE" "USE" -pLOC = pCostReserved 5 "loc" "loc" -pLHS = pCostReserved 5 "lhs" "loc" -pINST = pCostReserved 5 "inst" "inst" -pAt = pCostReserved 5 "@" "@" -pDot = pCostReserved 5 "." "." -pUScore = pCostReserved 5 "_" "_" -pColon = pCostReserved 5 ":" ":" -pDoubleColon = pCostReserved 5 "::" "::" -pEquals = pCostReserved 5 "=" "=" -pColonEquals = pCostReserved 5 ":=" ":=" -pTilde = pCostReserved 5 "~" "~" -pPlus = pCostReserved 5 "+" "+" -pBar = pCostReserved 5 "|" "|" -pIntersect = pCostReserved 5 "/\\" "/\\" -pMinus = pCostReserved 5 "-" "-" -pDoubleArrow = pCostReserved 5 "=>" "=>" -pSmallerEqual= pCostReserved 5 "<=" "<=" -pArrow = pCostReserved 5 "->" "->" -pStar = pCostReserved 5 "*" "*" -pSmaller = pCostReserved 5 "<" "<" -pMODULE = pCostReserved 5 "MODULE" "MODULE" -pUNIQUEREF = pCostReserved 5 "UNIQUEREF" "UNIQUEREF" -pAUGMENT = pCostReserved 5 "AUGMENT" "AUGMENT" -pAROUND = pCostReserved 5 "AROUND" "AROUND" -pMERGE = pCostReserved 5 "MERGE" "MERGE" -pAS = pCostReserved 5 "AS" "AS" -pSELF = pCostReserved 5 "SELF" "SELF" -pIMPORTS = pCostReserved 5 "imports" "imports" -pOPTPRAGMAS = pCostReserved 5 "optpragmas" "optpragmas" -pTOPLEVEL = pCostReserved 5 "toplevel" "toplevel" -pDATABLOCK = pCostReserved 5 "datablock" "datadecl block" -pRECBLOCK = pCostReserved 5 "recblock" "recursive block" +module Parser +where +import Data.Maybe +import UU.Parsing +import UU.Parsing.Machine(RealParser(..),RealRecogn(..),anaDynE,mkPR) +import ConcreteSyntax +import CommonTypes +import Patterns +import UU.Pretty(text,PP_Doc,empty,(>-<)) +import TokenDef +import Data.List (intersperse) +import Data.Char +import Scanner (Input(..),scanLit,input) +import System.FilePath +import Data.List +import Expression +import Macro --marcos +import UU.Scanner.Token +import UU.Scanner.TokenParser +import UU.Scanner.GenToken +import UU.Scanner.GenTokenOrd +import UU.Scanner.GenTokenParser +import UU.Scanner.Position +import UU.Scanner.TokenShow() +import System.Directory +import System.FilePath +import HsTokenScanner +import Options +import Scanner(lowercaseKeywords) + + +type AGParser = AnaParser Input Pair Token Pos + +pIdentifier, pIdentifierU, pIdentifierExcl :: AGParser Identifier +pIdentifierU = uncurry Ident <$> pConidPos + +-- Jeroen (3-10-2012): for some reason using pKeywordAsIdent +-- drastically slows down parsing of some of my AG files, as +-- in: I thought there was some infinite loop in there, but I +-- guess that eventually it could have given an answer. So +-- probably this does generate a lot of ambiguity. +pIdentifier = pIdentifierExcl -- <|> pKeywordAsIdent +pIdentifierExcl = uncurry Ident <$> pVaridPos + +-- see Scanner.lowercaseKeywords for the list of keywords that may +-- be used as an identifier. To prevent ambiguities, it's probably +-- sufficient when the keyword is always followed by a token that +-- can never follow an identifier for any possible prefix. +pKeywordAsIdent :: AGParser Identifier +pKeywordAsIdent = pAny (\nm -> Ident nm <$> pKeyPos nm) lowercaseKeywords + +parseAG :: Options -> [FilePath] -> String -> IO (AG,[Message Token Pos]) +parseAG opts searchPath file = do + (es,_,_,_,mesg) <- parseFile False opts searchPath file + return (AG es, mesg) + +--marcos +parseAGI :: Options -> [FilePath] -> String -> IO (AG, Maybe String) +parseAGI opts searchPath file + = do (es,_,_,ext,_) <- parseFile True opts searchPath file + return (AG es, ext) + + +depsAG :: Options -> [FilePath] -> String -> IO ([String], [Message Token Pos]) +depsAG opts searchPath file + = do let fn = normalise file + (_,_,fs,_,mesgs) <- parseFile False opts searchPath fn + return (filter (/= fn) fs, mesgs) + +-- marcos: added the parameter 'agi' and the 'ext' part +parseFile :: Bool -> Options -> [FilePath] -> String -> IO ([Elem],[String],[String], Maybe String,[Message Token Pos ]) +parseFile = parseFile' [] + +parseFile' :: [String] -> Bool -> Options -> [FilePath] -> String -> IO ([Elem],[String],[String], Maybe String,[Message Token Pos ]) +parseFile' parsedfiles agi opts searchPath filename + = do file <- normalise `fmap` resolveFile opts searchPath filename + if file `elem` parsedfiles + then return ([], [], parsedfiles, Nothing, []) + else do + txt <- readFile file + let searchPath' = takeDirectory file : searchPath -- search first relative to the including file + litMode = ".lag" `isSuffixOf` file + (files,text) = if litMode then scanLit txt + else ([],txt) + tokens = input opts (initPos file) text + + steps = parse (pElemsFiles agi) tokens + stop (_,fs,_,_,_) = null fs + cont (es,f:fs,allfs,ext,msg) + = do (ess,fss,allfss,_, msgs) <- parseFile' allfs agi opts searchPath' f + return (ess ++ es, fss ++ fs, allfss, ext, msg ++ msgs) + let (Pair (es,fls,ext) _ ,mesg) = evalStepsMessages steps + loopp stop cont (es,files ++ fls,file : parsedfiles, ext,mesg) + where + + -- + -- Option dependent AG Parsers inlined here + -- to have access to the opts + -- while retaining sharing + -- + + pElemsFiles :: Bool -> AGParser ([Elem],[String],Maybe String) + pElemsFiles agi = pFoldr (($),([],[],Nothing)) pElem' + where pElem' = addElem <$> pElem + <|> pINCLUDE *> (addInc <$> pStringPos) + <|> pEXTENDS *> (addExt <$> pStringPos) + addElem e (es,fs,ext) = (e:es, fs, ext) + addInc (fn,_) (es,fs,ext) + | noIncludes opts = (es, fs, ext) -- skip includes + | otherwise = (es,normalise fn:fs, ext) + addExt (fn,_) (es,fs,ext) + | noIncludes opts = (es, fs, ext) -- skip includes + | otherwise = if agi then (es,fs, Just fn') else (es,fn':fs, ext) --marcos + where fn' = normalise fn + + pCodescrapL = (\(ValToken _ str pos) -> (str, pos))<$> + parseScrapL "a code block" + + parseScrapL :: AGParser Token + parseScrapL + = let p acc = (\k (Input pos str next) -> + let (sc,rest) = case next of + Just (t@(ValToken TkTextln _ _), rs) -> (t,rs) + _ -> let (tok,p2,inp2) = codescrapL pos str + in (tok, input opts p2 inp2) + steps = k ( rest) + in (val (acc sc) steps) + ) + in anaDynE (mkPR (P (p ), R (p (const id)))) + + pElems :: AGParser Elems + pElems = pList_ng pElem + + pComplexType = List <$> pBracks pTypeEncapsulated + <|> Maybe <$ pMAYBE <*> pType + <|> Either <$ pEITHER <*> pType <*> pType + <|> Map <$ pMAP <*> pTypePrimitive <*> pType + <|> IntMap <$ pINTMAP <*> pType + <|> OrdSet <$ pSET <*> pType + <|> IntSet <$ pINTSET + <|> tuple <$> pParens (pListSep pComma field) + where field = (,) <$> ((Just <$> pIdentifier <* pTypeColon) `opt` Nothing) <*> pTypeEncapsulated + tuple xs = Tuple [(fromMaybe (Ident ("x"++show n) noPos) f, t) + | (n,(f,t)) <- zip [1..] xs + ] + + pOptClassContext' :: AGParser ClassContext + pOptClassContext' + | ocaml opts = pSucceed [] + | otherwise = pOptClassContext + + pTyVars :: AGParser [Identifier] + pTyVars + | ocaml opts = return <$> pTypeVar + <|> pSucceed [] + <|> pParens (pListSep pComma pTypeVar) + | otherwise = pList pIdentifier + + pElem :: AGParser Elem + pElem + = (\(pos, ct) -> Data pos ct) + <$> ( (\x -> (x, DataConstructor)) <$> (pDATA <|> pTYPE) + <|> (\x -> (x, RecordConstructor)) <$> pRECORD + ) + <*> pOptClassContext' + <*> pNontSet + <*> pTyVars + <*> pOptAttrs + <*> pAlts + <*> pSucceed False + <|> Attr <$> pATTR + <*> pOptClassContext' + <*> pNontSet + <*> pOptQuantifiers + <*> pAttrs + <|> Type <$> pTYPE + <*> pOptClassContext' + <*> pTypeCon + <*> pTyVars + <* pEquals + <*> pComplexType + <|> Sem <$> pSEM + <*> pOptClassContext' + <*> pNontSet + <*> pOptAttrs + <*> pOptQuantifiers + <*> pSemAlts + <|> Set <$> pSET + <*> pTypeCon + <*> ( False <$ pEquals + <|> True <$ pColon + ) + <*> pNontSet + <|> Deriving + <$> pDERIVING + <*> pNontSet + <* pColon + <*> pListSep pComma pIdentifierU + <|> Wrapper + <$> pWRAPPER + <*> pNontSet + <|> Nocatas + <$> pNOCATAS + <*> pNontSet + <|> Pragma + <$> pPRAGMA + <*> pList1 pIdentifier + <|> Module + <$> pMODULE + <*> pCodescrap' + <*> pCodescrap' + <*> pCodescrap' + <|> codeBlock <$> pBlockKind <*> ((Just <$ pATTACH <*> pTypeCon) <|> pSucceed Nothing) <*> pCodeBlock "a statement" + where codeBlock knd mbNt (txt,pos) = Txt pos knd mbNt (lines txt) + + pBlockKind :: AGParser BlockKind + pBlockKind = + BlockPragma <$ pOPTPRAGMAS + <|> BlockImport <$ pIMPORTS + <|> BlockMain <$ pTOPLEVEL -- block is moved to the toplevel ("main") module when "sepsemmods" is used + <|> BlockData <$ pDATABLOCK + <|> BlockRec <$ pRECBLOCK + <|> pSucceed BlockOther + + pAttrs :: AGParser Attrs + pAttrs + = Attrs <$> pOBrackPos <*> (concat <$> pList pInhAttrNames "inherited attribute declarations") + <* pBar <*> (concat <$> pList pAttrNames "chained attribute declarations" ) + <* pBar <*> (concat <$> pList pAttrNames "synthesised attribute declarations" ) + <* pCBrack + <|> (\ds -> Attrs (fst $ head ds) [n | (_,(nms,_,_)) <- ds, n <- nms] [n | (_,(_,nms,_)) <- ds, n <- nms] [n | (_,(_,_,nms)) <- ds, n <- nms]) <$> pList1 pSingleAttrDefs + + pSingleAttrDefs :: AGParser (Pos, (AttrNames, AttrNames, AttrNames)) + pSingleAttrDefs + = (\p is -> (p, (is,[],[]))) <$> pINH <*> pList1Sep pComma pSingleInhAttrDef + <|> (\p is -> (p, ([],[],is))) <$> pSYN <*> pList1Sep pComma pSingleSynAttrDef + <|> (\p is -> (p, ([],is,[]))) <$> pCHN <*> pList1Sep pComma pSingleChnAttrDef + + pSingleInhAttrDef :: AGParser (Identifier,Type,(String,String,String)) + pSingleInhAttrDef + = (\v tp -> (v,tp,("","",""))) <$> pAttrIdentifier <* pTypeColon <*> pTypeOrSelf "inh attribute declaration" + + pSingleSynAttrDef :: AGParser (Identifier,Type,(String,String,String)) + pSingleSynAttrDef + = (\v u tp -> (v,tp,u)) <$> pAttrIdentifier <*> pUse <* pTypeColon <*> pTypeOrSelf "syn attribute declaration" + + pSingleChnAttrDef :: AGParser (Identifier,Type,(String,String,String)) + pSingleChnAttrDef + = (\v tp -> (v,tp,("","",""))) <$> pAttrIdentifier <* pTypeColon <*> pTypeOrSelf "chn attribute declaration" + + pOptAttrs :: AGParser Attrs + pOptAttrs = pAttrs `opt` Attrs noPos [] [] [] + + pInhAttrNames :: AGParser AttrNames + pInhAttrNames + = (\vs tp -> map (\v -> (v,tp,("","",""))) vs) + <$> pAttrIdentifiers <* pTypeColon <*> pTypeOrSelf "attribute declarations" + + pAttrNames :: AGParser AttrNames + pAttrNames + = (\vs use tp -> map (\v -> (v,tp,use)) vs) + <$> pAttrIdentifiers <*> pUse <* pTypeColon <*> pTypeOrSelf "attribute declarations" + + pAlt :: AGParser Alt + pAlt = (Alt <$> pBar <*> pSimpleConstructorSet <*> (pList1_ng pTypeVar <* pDot <|> pSucceed []) <*> pFields <*> pMaybeMacro "a datatype alternative") + + pAlts :: AGParser Alts + pAlts = pList_ng pAlt "datatype alternatives" + + pFields :: AGParser Fields + pFields = concat <$> pList_ng pField "fields" + + pField :: AGParser Fields + pField + = (\nms tp -> map (\nm -> FChild nm tp) nms) <$> pAttrIdentifiers <* pTypeColon <*> pType + <|> (\s -> [FChild (Ident (mklower $ getName s) (getPos s)) (NT s [] False)]) <$> pIdentifierU + <|> (\t -> [FCtx [t]]) <$ pSmallerEqual <*> pTypePrimitive + + pSemAlt :: AGParser SemAlt + pSemAlt = SemAlt <$> pBar <*> pConstructorSet <*> pSemDefs "SEM alternative" + + pSemAlts :: AGParser SemAlts + pSemAlts = pList pSemAlt "SEM alternatives" + + pSemDef :: AGParser [SemDef] + pSemDef + = (\x y fs -> map (\f -> f x y) fs) <$> pMaybeRuleName <*> pFieldIdentifier <*> pList1 pAttrDef + <|> pLOC *> pList1 pLocDecl + <|> pINST *> pList1 pInstDecl + <|> pSEMPRAGMA *> pList1 (SemPragma <$> pNames) + <|> (\n e -> [AugmentDef n e]) <$ pAugmentToken <*> pAttrIdentifier <* pAssign <*> pExpr + <|> (\n e -> [AroundDef n e]) <$ pAROUND <*> pAttrIdentifier <* pAssign <*> pExpr + <|> (\a b -> [AttrOrderBefore a [b]]) <$> pList1 pAttrOrIdent <* pSmaller <*> pAttrOrIdent + <|> (\sources target nt expr -> [MergeDef target nt sources expr]) <$ pMERGE <*> (pList1_ng pIdentifier <* pAS <|> pSucceed []) <*> pIdentifier <* pTypeColon <*> pIdentifierU <* pAssign <*> pExpr + <|> (\mbNm pat (owrt,pos,pur,eager) exp -> [Def pos mbNm (pat ()) exp owrt pur eager]) <$> pMaybeRuleName <*> pPattern (const <$> pAttr) <*> pRuleSym <*> pExpr + + pMaybeRuleName :: AGParser (Maybe Identifier) + pMaybeRuleName + = (Just <$> pIdentifier <* pColon "rule name") + <|> pSucceed Nothing + + pAttrDef :: AGParser (Maybe Identifier -> Identifier -> SemDef) + pAttrDef + = (\pat (owrt,pos,pur,eager) exp mbNm fld -> Def pos mbNm (pat fld) exp owrt pur eager) + <$ pDot <*> pattern <*> pRuleSym <*> pExpr + where pattern = pPattern pVar + <|> (\ir a fld -> ir $ Alias fld a (Underscore noPos)) <$> ((Irrefutable <$ pTilde) `opt` id) <*> pAttrIdentifier + + pLocDecl :: AGParser SemDef + pLocDecl = pDot <**> (pIdentifier <**> (pTypeColon <**> ( (\(tp,pos) _ ident _ -> TypeDef pos ident tp) <$> pLocType + <|> (\ref _ ident _ -> UniqueDef ident ref) <$ pUNIQUEREF <*> pIdentifier ))) + + pLocType :: AGParser (Type, Pos) + pLocType = (\u -> (Haskell $ getName u, getPos u)) <$> pTypeCon + <|> (\(s,p) -> (Haskell s,p)) <$> pCodescrap "a type" + + pInstDecl :: AGParser SemDef + pInstDecl = (\ident tp -> TypeDef (getPos ident) ident tp) + <$ pDot <*> pIdentifier <* pTypeColon <*> pTypeNt + + pSemDefs :: AGParser SemDefs + pSemDefs = concat <$> pList_ng pSemDef "attribute rules" + + pExpr :: AGParser Expression + pExpr = (\(str,pos) -> Expression pos (lexTokens opts pos str)) <$> pCodescrapL "an expression" + + pTypeColon :: AGParser Pos + pTypeColon + = if doubleColons opts + then pDoubleColon + else pColon + + --marcos + pMaybeMacro :: AGParser MaybeMacro + pMaybeMacro = Just <$ pDoubleArrow <*> pMacro + <|> pSucceed Nothing + + pMacro :: AGParser Macro + pMacro + = Macro <$> pIdentifierU + <*> pList1 pMacroChild + "macro" + + pMacroChild :: AGParser MacroChild + pMacroChild + = (pIdentifier <* pEquals) <**> + (flip RuleChild <$> pMacro <|> + flip ChildChild <$> pIdentifier <|> + flip ValueChild <$> pCodescrap' ) + + pTypeNt :: AGParser Type + pTypeNt + = ((\nt -> mkNtType nt []) <$> pTypeCon "nonterminal name (no brackets)") + <|> (pParens (mkNtType <$> pTypeCon <*> pList pTypeHaskellAnyAsString) "nonterminal name with parameters (using parenthesis)") + + pTypeCon :: AGParser Identifier + pTypeCon + | ocaml opts = pIdentifierExcl + | otherwise = pIdentifierU + + pTypeVar :: AGParser Identifier + pTypeVar + | ocaml opts = (\(nm, pos) -> Ident nm pos) <$> pTextnmPos + | otherwise = pIdentifier + + pTypeHaskellAnyAsString :: AGParser String + pTypeHaskellAnyAsString + = getName <$> pTypeVar + <|> getName <$> pTypeCon + <|> pCodescrap' "a type" + + -- if the type is within some kind of parentheses or brackets (then we allow lowercase identifiers as well) + pTypeEncapsulated :: AGParser Type + pTypeEncapsulated + = pParens pTypeEncapsulated + <|> mkNtType <$> pTypeCon <*> pList pTypeHaskellAnyAsString + <|> (Haskell . getName) <$> pTypeVar + <|> pTypePrimitive + + pTypePrimitive :: AGParser Type + pTypePrimitive + = Haskell <$> pCodescrap' "a type" + + pType :: AGParser Type + pType = pTypeNt + <|> pTypePrimitive + + pTypeOrSelf :: AGParser Type + pTypeOrSelf = pType <|> Self <$ pSELF + + pOptClassContext :: AGParser ClassContext + pOptClassContext + = pClassContext <* pDoubleArrow + <|> pSucceed [] + + pClassContext :: AGParser ClassContext + pClassContext + = pListSep pComma ((,) <$> pIdentifierU <*> pList pTypeHaskellAnyAsString) + + pNontSet = set0 where + set0 = pChainr (Intersect <$ pIntersect) set1 + set1 = pChainl (Difference <$ pMinus) set2 + set2 = pChainr (pSucceed Union) set3 + set3 = pTypeCon <**> opt (flip Path <$ pArrow <*> pTypeCon) NamedSet + <|> All <$ pStar + <|> pParens set0 + + -- + -- End of AG Parser + -- + +resolveFile :: Options -> [FilePath] -> FilePath -> IO FilePath +resolveFile opts path fname = search (path ++ ["."]) + where search (p:ps) = do let filename = joinPath [p, fname] + fExists <- doesFileExist filename + if fExists + then return filename + else do let filename' = joinPath [p, replaceExtension fname "ag"] + fExists' <- doesFileExist filename' + if fExists' + then return filename' + else search ps + search [] = do + outputStr opts ("File: " ++ show fname ++ " not found in search path: " ++ show (concat (intersperse ";" (path ++ ["."]))) ++ "\n") + failWithCode opts 1 + return (error "resolveFile: file not found") + +evalStepsMessages :: (Eq s, Show s, Show p) => Steps a s p -> (a,[Message s p]) +evalStepsMessages steps = case steps of + OkVal v rest -> let (arg,ms) = evalStepsMessages rest + in (v arg,ms) + Ok rest -> evalStepsMessages rest + Cost _ rest -> evalStepsMessages rest + StRepair _ msg rest -> let (v,ms) = evalStepsMessages rest + in (v, msg:ms) + Best _ rest _ -> evalStepsMessages rest + NoMoreSteps v -> (v,[]) + +loopp ::(a->Bool) -> (a->IO a) -> a -> IO a +loopp pred cont x | pred x = return x + | otherwise = do x' <- cont x + loopp pred cont x' + +codescrapL p [] = (valueToken TkTextln "" p,p,[]) +codescrapL p (x:xs) | isSpace x = (updPos' x p) codescrapL xs + | otherwise = let refcol = column p + (p',sc,rest) = scrapL refcol p (x:xs) + in (valueToken TkTextln sc p,p',rest) + +scrapL ref p (x:xs) | isSpace x || column p >= ref = + let (p'',sc,inp) = updPos' x p (scrapL ref) xs + in (p'',x:sc,inp) + | otherwise =(p,[],x:xs) +scrapL ref p [] = (p,[],[]) + +pNames :: AGParser [Identifier] +pNames = pIdentifiers + + +-- Insertion is expensive for pCodeBlock in order to prevent infinite inserts. +pCodeBlock :: AGParser (String,Pos) +pCodeBlock = pCostValToken 90 TkTextln "" "a code block" + +pOptQuantifiers :: AGParser [String] +pOptQuantifiers = (return <$ pDoubleColon <*> pCodescrap') `opt` [] + +pIdentifiers :: AGParser [Identifier] +pIdentifiers = pList1Sep pComma pIdentifier "lowercase identifiers" + +pAttrIdentifier :: AGParser Identifier +pAttrIdentifier = pIdentifier + <|> (\pos -> Ident "imports" pos) <$> pIMPORTS + <|> (\pos -> Ident "toplevel" pos) <$> pTOPLEVEL + +pAttrIdentifiers :: AGParser [Identifier] +pAttrIdentifiers = pList1Sep pComma pAttrIdentifier "lowercase identifiers" + +pUse :: AGParser (String,String,String) +pUse = ( (\u x y->(x,y,show u)) <$> pUSE <*> pCodescrap' <*> pCodescrap') `opt` ("","","") "USE declaration" + +mklower :: String -> String +mklower (x:xs) = toLower x : xs +mklower [] = [] + +pSimpleConstructorSet :: AGParser ConstructorSet +pSimpleConstructorSet = CName <$> pIdentifierU + <|> CAll <$ pStar + <|> pParens pConstructorSet + +pConstructorSet :: AGParser ConstructorSet +pConstructorSet = pChainl (CDifference <$ pMinus) term2 + where term2 = pChainr (pSucceed CUnion) term1 + term1 = CName <$> pIdentifierU + <|> CAll <$ pStar + +pFieldIdentifier :: AGParser Identifier +pFieldIdentifier = pIdentifier + <|> Ident "lhs" <$> pLHS + <|> Ident "loc" <$> pLOC + <|> Ident "inst" <$> pINST + +pAugmentToken :: AGParser () +pAugmentToken = () <$ (pAUGMENT <|> pPlus) + +pAttr = (,) <$> pFieldIdentifier <* pDot <*> pAttrIdentifier + +pAttrOrIdent + = OccAttr <$> pFieldIdentifier <* pDot <*> pAttrIdentifier + <|> OccRule <$> pIdentifier + +nl2sp :: Char -> Char +nl2sp '\n' = ' ' +nl2sp '\r' = ' ' +nl2sp x = x + +pVar :: AGParser (Identifier -> (Identifier, Identifier)) +pVar = (\att fld -> (fld,att)) <$> pAttrIdentifier + +pAssign :: AGParser Bool +pAssign = False <$ pReserved "=" + <|> True <$ pReserved ":=" + +pRuleSym :: AGParser (Bool, Pos, Bool, Bool) +pRuleSym = (\p -> (False, p, True, False)) <$> pReserved "=" + <|> (\p -> (True, p, True, False)) <$> pReserved ":=" + <|> (\p -> (False, p, True, False)) <$> pReserved "<-" + <|> (\p -> (False, p, True, True)) <$> pReserved "<<-" + +pPattern :: AGParser (a -> (Identifier,Identifier)) -> AGParser (a -> Pattern) +pPattern pvar = pPattern2 where + pPattern0 = (\i pats a -> Constr i (map ($ a) pats)) + <$> pIdentifierU <*> pList pPattern1 + <|> pPattern1 "a pattern" + pPattern1 = pvariable + <|> pPattern2 + pvariable = (\ir var pat a -> case var a of (fld,att) -> ir $ Alias fld att (pat a)) + <$> ((Irrefutable <$ pTilde) `opt` id) <*> pvar <*> ((pAt *> pPattern1) `opt` const (Underscore noPos)) + pPattern2 = (mkTuple <$> pOParenPos <*> pListSep pComma pPattern0 <* pCParen ) + <|> (const . Underscore) <$> pUScore "a pattern" + where mkTuple _ [x] a = x a + mkTuple p xs a = Product p (map ($ a) xs) + +pCostSym' c t = pCostSym c t t + +pCodescrap' :: AGParser String +pCodescrap' = fst <$> pCodescrap + +pCodescrap :: AGParser (String,Pos) +pCodescrap = pCodeBlock + +pSEM, pATTR, pDATA, pRECORD, pUSE, pLOC,pINCLUDE, pTYPE, pEquals, pColonEquals, pTilde, + pEXTENDS, --marcos + pBar, pColon, pLHS,pINST,pSET,pDERIVING,pMinus,pIntersect,pDoubleArrow,pArrow, + pDot, pUScore, pEXT,pAt,pStar, pSmaller, pWRAPPER, pNOCATAS, pPRAGMA, pMAYBE, pEITHER, pMAP, pINTMAP, + pMODULE, pATTACH, pUNIQUEREF, pINH, pSYN, pAUGMENT, pPlus, pAROUND, pSEMPRAGMA, pMERGE, pAS, pSELF, + pIMPORTS, pOPTPRAGMAS, pSmallerEqual, pINTSET, pDATABLOCK, pRECBLOCK + :: AGParser Pos +pSET = pCostReserved 90 "SET" "SET" +pDERIVING = pCostReserved 90 "DERIVING" "DERIVING" +pWRAPPER = pCostReserved 90 "WRAPPER" "WRAPPER" +pNOCATAS = pCostReserved 90 "NOCATAS" "NOCATAS" +pPRAGMA = pCostReserved 90 "PRAGMA" "PRAGMA" +pSEMPRAGMA = pCostReserved 90 "SEMPRAGMA" "SEMPRAGMA" +pATTACH = pCostReserved 90 "ATTACH" "ATTACH" +pDATA = pCostReserved 90 "DATA" "DATA" +pRECORD = pCostReserved 90 "RECORD" "RECORD" +pEXT = pCostReserved 90 "EXT" "EXT" +pATTR = pCostReserved 90 "ATTR" "ATTR" +pSEM = pCostReserved 90 "SEM" "SEM" +pINCLUDE = pCostReserved 90 "INCLUDE" "INCLUDE" +pEXTENDS = pCostReserved 90 "EXTENDS" "EXTENDS" --marcos +pTYPE = pCostReserved 90 "TYPE" "TYPE" +pINH = pCostReserved 90 "INH" "INH" +pSYN = pCostReserved 90 "SYN" "SYN" +pCHN = pCostReserved 90 "CHN" "CHN" +pMAYBE = pCostReserved 5 "MAYBE" "MAYBE" +pEITHER = pCostReserved 5 "EITHER" "EITHER" +pMAP = pCostReserved 5 "MAP" "MAP" +pINTMAP = pCostReserved 5 "INTMAP" "INTMAP" +pINTSET = pCostReserved 5 "INTSET" "INTSET" +pUSE = pCostReserved 5 "USE" "USE" +pLOC = pCostReserved 5 "loc" "loc" +pLHS = pCostReserved 5 "lhs" "loc" +pINST = pCostReserved 5 "inst" "inst" +pAt = pCostReserved 5 "@" "@" +pDot = pCostReserved 5 "." "." +pUScore = pCostReserved 5 "_" "_" +pColon = pCostReserved 5 ":" ":" +pDoubleColon = pCostReserved 5 "::" "::" +pEquals = pCostReserved 5 "=" "=" +pColonEquals = pCostReserved 5 ":=" ":=" +pTilde = pCostReserved 5 "~" "~" +pPlus = pCostReserved 5 "+" "+" +pBar = pCostReserved 5 "|" "|" +pIntersect = pCostReserved 5 "/\\" "/\\" +pMinus = pCostReserved 5 "-" "-" +pDoubleArrow = pCostReserved 5 "=>" "=>" +pSmallerEqual= pCostReserved 5 "<=" "<=" +pArrow = pCostReserved 5 "->" "->" +pStar = pCostReserved 5 "*" "*" +pSmaller = pCostReserved 5 "<" "<" +pMODULE = pCostReserved 5 "MODULE" "MODULE" +pUNIQUEREF = pCostReserved 5 "UNIQUEREF" "UNIQUEREF" +pAUGMENT = pCostReserved 5 "AUGMENT" "AUGMENT" +pAROUND = pCostReserved 5 "AROUND" "AROUND" +pMERGE = pCostReserved 5 "MERGE" "MERGE" +pAS = pCostReserved 5 "AS" "AS" +pSELF = pCostReserved 5 "SELF" "SELF" +pIMPORTS = pCostReserved 5 "imports" "imports" +pOPTPRAGMAS = pCostReserved 5 "optpragmas" "optpragmas" +pTOPLEVEL = pCostReserved 5 "toplevel" "toplevel" +pDATABLOCK = pCostReserved 5 "datablock" "datadecl block" +pRECBLOCK = pCostReserved 5 "recblock" "recursive block" diff --git a/src/Pretty.hs b/src/Pretty.hs --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -1,191 +1,191 @@ -------------------------------------------------------------------------- --- Subset of UU.Pretty, based on very simple pretty printing --- Extended with line-nr tracking -------------------------------------------------------------------------- - -module Pretty - ( PP_Doc, PP(..) - , disp - - , (>|<), (>-<) - , (>#<) - , ppWithLineNr - , hlist, vlist, hv - , fill - , indent - - , pp_block - , vlist_sep - , pp_parens - , pp_braces - , hv_sp - - , empty, empty1, text - , isEmpty - ) - where - -import Data.List(intersperse) - -------------------------------------------------------------------------- --- Doc structure -------------------------------------------------------------------------- - -data Doc - = Emp - | Emp1 - | Str !String -- basic string - | Hor Doc !Doc -- horizontal positioning - | Ver Doc !Doc -- vertical positioning - | Ind !Int Doc -- indent - | Line (Int -> Doc) -- line nr - -type PP_Doc = Doc - -------------------------------------------------------------------------- --- Basic combinators -------------------------------------------------------------------------- - -infixr 3 >|<, >#< -infixr 2 >-< - -(>|<) :: (PP a, PP b) => a -> b -> PP_Doc -l >|< r = pp l `Hor` pp r - -(>-<) :: (PP a, PP b) => a -> b -> PP_Doc -l >-< r | isEmpty a = b - | isEmpty b = a - | otherwise = a `Ver` b - where a = pp l - b = pp r - -(>#<) :: (PP a, PP b) => a -> b -> PP_Doc -l >#< r | isEmpty a = b - | isEmpty b = a - | otherwise = a >|< " " >|< b - where a = pp l - b = pp r - -indent :: PP a => Int -> a -> PP_Doc -indent i d = Ind i $ pp d - -text :: String -> PP_Doc -text s - = let ls = lines s - ls' | null ls = [""] - | otherwise = ls - in vlist (map Str ls') - -empty :: PP_Doc -empty = Emp - --- empty1 is not a zero for >#< -empty1 :: PP_Doc -empty1 = Emp1 - -ppWithLineNr :: PP a => (Int -> a) -> PP_Doc -ppWithLineNr f = Line (pp . f) - -------------------------------------------------------------------------- --- Derived combinators -------------------------------------------------------------------------- - -hlist, vlist :: PP a => [a] -> PP_Doc -vlist [] = empty -vlist as = foldr (>-<) empty as -hlist [] = empty -hlist as = foldr (>|<) empty as - -hv :: PP a => [a] -> PP_Doc -hv = vlist - -hv_sp :: PP a => [a] -> PP_Doc -hv_sp = foldr (>#<) empty - -fill :: PP a => [a] -> PP_Doc -fill = hlist - -pp_block:: (PP a, PP b, PP c) => a -> b -> c -> [PP_Doc] -> PP_Doc -pp_block o c s as = pp o >|< hlist (intersperse (pp s) as) >|< pp c - -pp_parens :: PP a => a -> PP_Doc -pp_parens p = '(' >|< p >|< ')' - -pp_braces :: PP a => a -> PP_Doc -pp_braces p = '{' >-< p >-< '}' - -vlist_sep :: (PP a, PP b) => a -> [b] -> PP_Doc -vlist_sep sep lst - = vlist (intersperse (pp sep) (map pp lst)) - -------------------------------------------------------------------------- --- PP class -------------------------------------------------------------------------- - -class Show a => PP a where - pp :: a -> PP_Doc - pp = text . show - - ppList :: [a] -> PP_Doc - ppList as = hlist as - -instance PP Doc where - pp = id - -instance PP Char where - pp c = text [c] - ppList = text - -instance PP a => PP [a] where - pp = ppList - -instance Show Doc where - show p = disp p 200 "" - -instance PP Int where - pp = text . show - -instance PP Float where - pp = text . show - -------------------------------------------------------------------------- --- Observation -------------------------------------------------------------------------- - -isEmpty :: PP_Doc -> Bool -isEmpty Emp = True -isEmpty Emp1 = False -isEmpty (Ver d1 d2) = isEmpty d1 && isEmpty d2 -isEmpty (Hor d1 d2) = isEmpty d1 && isEmpty d2 -isEmpty (Ind _ d ) = isEmpty d -isEmpty _ = False - -------------------------------------------------------------------------- --- Rendering -------------------------------------------------------------------------- - -disp :: PP_Doc -> Int -> ShowS -disp d0 _ s0 - = r - where (r,_,_) = put 0 1 d0 s0 - put p l d s - = case d of - Emp -> (s,p,l) - Emp1 -> (s,p,l) - Str s' -> (s' ++ s,p + length s',l) - Ind i d1 -> (ind ++ r',p', l') - where (r',p',l') = put (p+i) l d1 s - ind = replicate i ' ' - Hor d1 d2 -> (r1,p2,l2) - where (r1,p1,l1) = put p l d1 r2 - (r2,p2,l2) = put p1 l1 d2 s - Ver d1 d2 | isEmpty d1 - -> put p l d2 s - Ver d1 d2 | isEmpty d2 - -> put p l d1 s - Ver d1 d2 -> (r1,p2,l2) - where (r1,_ ,l1) = put p l d1 $ "\n" ++ ind ++ r2 - (r2,p2,l2) = put p (l1+1) d2 s - ind = replicate p ' ' - Line f -> (r',p',l') - where (r',p',l') = put p l (f l) s +------------------------------------------------------------------------- +-- Subset of UU.Pretty, based on very simple pretty printing +-- Extended with line-nr tracking +------------------------------------------------------------------------- + +module Pretty + ( PP_Doc, PP(..) + , disp + + , (>|<), (>-<) + , (>#<) + , ppWithLineNr + , hlist, vlist, hv + , fill + , indent + + , pp_block + , vlist_sep + , pp_parens + , pp_braces + , hv_sp + + , empty, empty1, text + , isEmpty + ) + where + +import Data.List(intersperse) + +------------------------------------------------------------------------- +-- Doc structure +------------------------------------------------------------------------- + +data Doc + = Emp + | Emp1 + | Str !String -- basic string + | Hor Doc !Doc -- horizontal positioning + | Ver Doc !Doc -- vertical positioning + | Ind !Int Doc -- indent + | Line (Int -> Doc) -- line nr + +type PP_Doc = Doc + +------------------------------------------------------------------------- +-- Basic combinators +------------------------------------------------------------------------- + +infixr 3 >|<, >#< +infixr 2 >-< + +(>|<) :: (PP a, PP b) => a -> b -> PP_Doc +l >|< r = pp l `Hor` pp r + +(>-<) :: (PP a, PP b) => a -> b -> PP_Doc +l >-< r | isEmpty a = b + | isEmpty b = a + | otherwise = a `Ver` b + where a = pp l + b = pp r + +(>#<) :: (PP a, PP b) => a -> b -> PP_Doc +l >#< r | isEmpty a = b + | isEmpty b = a + | otherwise = a >|< " " >|< b + where a = pp l + b = pp r + +indent :: PP a => Int -> a -> PP_Doc +indent i d = Ind i $ pp d + +text :: String -> PP_Doc +text s + = let ls = lines s + ls' | null ls = [""] + | otherwise = ls + in vlist (map Str ls') + +empty :: PP_Doc +empty = Emp + +-- empty1 is not a zero for >#< +empty1 :: PP_Doc +empty1 = Emp1 + +ppWithLineNr :: PP a => (Int -> a) -> PP_Doc +ppWithLineNr f = Line (pp . f) + +------------------------------------------------------------------------- +-- Derived combinators +------------------------------------------------------------------------- + +hlist, vlist :: PP a => [a] -> PP_Doc +vlist [] = empty +vlist as = foldr (>-<) empty as +hlist [] = empty +hlist as = foldr (>|<) empty as + +hv :: PP a => [a] -> PP_Doc +hv = vlist + +hv_sp :: PP a => [a] -> PP_Doc +hv_sp = foldr (>#<) empty + +fill :: PP a => [a] -> PP_Doc +fill = hlist + +pp_block:: (PP a, PP b, PP c) => a -> b -> c -> [PP_Doc] -> PP_Doc +pp_block o c s as = pp o >|< hlist (intersperse (pp s) as) >|< pp c + +pp_parens :: PP a => a -> PP_Doc +pp_parens p = '(' >|< p >|< ')' + +pp_braces :: PP a => a -> PP_Doc +pp_braces p = '{' >-< p >-< '}' + +vlist_sep :: (PP a, PP b) => a -> [b] -> PP_Doc +vlist_sep sep lst + = vlist (intersperse (pp sep) (map pp lst)) + +------------------------------------------------------------------------- +-- PP class +------------------------------------------------------------------------- + +class Show a => PP a where + pp :: a -> PP_Doc + pp = text . show + + ppList :: [a] -> PP_Doc + ppList as = hlist as + +instance PP Doc where + pp = id + +instance PP Char where + pp c = text [c] + ppList = text + +instance PP a => PP [a] where + pp = ppList + +instance Show Doc where + show p = disp p 200 "" + +instance PP Int where + pp = text . show + +instance PP Float where + pp = text . show + +------------------------------------------------------------------------- +-- Observation +------------------------------------------------------------------------- + +isEmpty :: PP_Doc -> Bool +isEmpty Emp = True +isEmpty Emp1 = False +isEmpty (Ver d1 d2) = isEmpty d1 && isEmpty d2 +isEmpty (Hor d1 d2) = isEmpty d1 && isEmpty d2 +isEmpty (Ind _ d ) = isEmpty d +isEmpty _ = False + +------------------------------------------------------------------------- +-- Rendering +------------------------------------------------------------------------- + +disp :: PP_Doc -> Int -> ShowS +disp d0 _ s0 + = r + where (r,_,_) = put 0 1 d0 s0 + put p l d s + = case d of + Emp -> (s,p,l) + Emp1 -> (s,p,l) + Str s' -> (s' ++ s,p + length s',l) + Ind i d1 -> (ind ++ r',p', l') + where (r',p',l') = put (p+i) l d1 s + ind = replicate i ' ' + Hor d1 d2 -> (r1,p2,l2) + where (r1,p1,l1) = put p l d1 r2 + (r2,p2,l2) = put p1 l1 d2 s + Ver d1 d2 | isEmpty d1 + -> put p l d2 s + Ver d1 d2 | isEmpty d2 + -> put p l d1 s + Ver d1 d2 -> (r1,p2,l2) + where (r1,_ ,l1) = put p l d1 $ "\n" ++ ind ++ r2 + (r2,p2,l2) = put p (l1+1) d2 s + ind = replicate p ' ' + Line f -> (r',p',l') + where (r',p',l') = put p l (f l) s diff --git a/src/RhsCheck.hs b/src/RhsCheck.hs --- a/src/RhsCheck.hs +++ b/src/RhsCheck.hs @@ -1,65 +1,65 @@ -module RhsCheck(checkRhs,checkBlock,checkTy) where - -import Language.Haskell.Exts (parseExpWithMode, parseModuleWithMode, parseTypeWithMode, srcLine, srcColumn, srcFilename, baseFixities, glasgowExts, ParseMode (..), defaultParseMode, ParseResult (..), Extension (..)) -import ErrorMessages -import Expression -import HsToken -import UU.Scanner.Position - -checkRhs,checkBlock,checkTy :: Expression -> Errors -checkRhs = check parseExpWithMode -checkBlock = check parseModuleWithMode -checkTy = check parseTypeWithMode - -check :: (ParseMode -> String -> ParseResult a) -> Expression -> Errors -check p (Expression pos tks) = case res of - ParseOk _ -> [] - ParseFailed loc msg -> let pos' = Pos (srcLine loc + line pos - 1) (srcColumn loc) (srcFilename loc) - in [HsParseError pos' msg] - where - pos0 = Pos (line pos) 1 (file pos) - str = toString pos0 tks - res = p mode str - bf = case baseFixities of - [] -> Nothing - xs -> Just xs - mode = defaultParseMode { parseFilename = file pos, ignoreLanguagePragmas = False, extensions = exts - , ignoreLinePragmas = False, fixities = bf } - -exts :: [Extension] -exts = glasgowExts - -toString :: Pos -> HsTokens -> String -toString _ [] = "" -toString cPos (tk:tks) = move ++ current ++ next - where - tkPos = getPos tk - move = addSpacing (line tkPos - line cPos) (column cPos) (column tkPos) - current = fmt tk - nPos = upd tkPos current - next = toString nPos tks - -getPos :: HsToken -> Pos -getPos (AGLocal _ pos _) = pos -getPos (AGField _ _ pos _) = pos -getPos (HsToken _ pos) = pos -getPos (CharToken _ pos) = pos -getPos (StrToken _ pos) = pos -getPos (Err _ pos) = pos - -fmt :: HsToken -> String -fmt (AGLocal var _ _) = "_" ++ show var -fmt (AGField field attr _ _) = "_" ++ show field ++ "_" ++ show attr -fmt (HsToken val _) = val -fmt (CharToken val _) = show val -fmt (StrToken val _) = show val -fmt (Err val _) = val - -upd :: Pos -> String -> Pos -upd p s = foldl adv p s - -addSpacing :: Int -> Int -> Int -> String -addSpacing l c1 c2 = replicate l '\n' ++ replicate c ' ' - where - c | l == 0 = c2 - c1 - | otherwise = c2 - 1 +module RhsCheck(checkRhs,checkBlock,checkTy) where + +import Language.Haskell.Exts (parseExpWithMode, parseModuleWithMode, parseTypeWithMode, srcLine, srcColumn, srcFilename, baseFixities, glasgowExts, ParseMode (..), defaultParseMode, ParseResult (..), Extension (..)) +import ErrorMessages +import Expression +import HsToken +import UU.Scanner.Position + +checkRhs,checkBlock,checkTy :: Expression -> Errors +checkRhs = check parseExpWithMode +checkBlock = check parseModuleWithMode +checkTy = check parseTypeWithMode + +check :: (ParseMode -> String -> ParseResult a) -> Expression -> Errors +check p (Expression pos tks) = case res of + ParseOk _ -> [] + ParseFailed loc msg -> let pos' = Pos (srcLine loc + line pos - 1) (srcColumn loc) (srcFilename loc) + in [HsParseError pos' msg] + where + pos0 = Pos (line pos) 1 (file pos) + str = toString pos0 tks + res = p mode str + bf = case baseFixities of + [] -> Nothing + xs -> Just xs + mode = defaultParseMode { parseFilename = file pos, ignoreLanguagePragmas = False, extensions = exts + , ignoreLinePragmas = False, fixities = bf } + +exts :: [Extension] +exts = glasgowExts + +toString :: Pos -> HsTokens -> String +toString _ [] = "" +toString cPos (tk:tks) = move ++ current ++ next + where + tkPos = getPos tk + move = addSpacing (line tkPos - line cPos) (column cPos) (column tkPos) + current = fmt tk + nPos = upd tkPos current + next = toString nPos tks + +getPos :: HsToken -> Pos +getPos (AGLocal _ pos _) = pos +getPos (AGField _ _ pos _) = pos +getPos (HsToken _ pos) = pos +getPos (CharToken _ pos) = pos +getPos (StrToken _ pos) = pos +getPos (Err _ pos) = pos + +fmt :: HsToken -> String +fmt (AGLocal var _ _) = "_" ++ show var +fmt (AGField field attr _ _) = "_" ++ show field ++ "_" ++ show attr +fmt (HsToken val _) = val +fmt (CharToken val _) = show val +fmt (StrToken val _) = show val +fmt (Err val _) = val + +upd :: Pos -> String -> Pos +upd p s = foldl adv p s + +addSpacing :: Int -> Int -> Int -> String +addSpacing l c1 c2 = replicate l '\n' ++ replicate c ' ' + where + c | l == 0 = c2 - c1 + | otherwise = c2 - 1 diff --git a/src/Scanner.hs b/src/Scanner.hs --- a/src/Scanner.hs +++ b/src/Scanner.hs @@ -1,234 +1,234 @@ -{-# LANGUAGE MagicHash, UnboxedTuples, FlexibleInstances #-} -module Scanner where -import GHC.Prim -import TokenDef -import UU.Scanner.Position -import UU.Scanner.Token -import UU.Parsing(InputState(..),Either'(..)) -import Data.Maybe -import Data.List -import Data.Char -import UU.Scanner.GenToken -import Options (Options (..)) - -data Input = Input !Pos String (Maybe (Token, Input)) - -instance InputState Input Token Pos where - splitStateE input@(Input _ _ next) = - case next of - Nothing -> Right' input - Just (s, rest) -> Left' s rest - splitState (Input _ _ next) = - case next of - Nothing -> error "splitState on empty input" - Just (s, rest) -> (# s, rest #) - getPosition (Input pos _ next) = case next of - Just (s,_) -> position s - Nothing -> pos -- end of file - - -input :: Options -> Pos -> String -> Input -input opts pos inp = Input pos - inp - (case scan opts pos inp of - Nothing -> Nothing - Just (s,p,r) -> Just (s, input opts p r) - ) - -type Lexer s = Pos -> String -> Maybe (s,Pos,String) - -scan :: Options -> Lexer Token -scan opts p0 - | column p0 == 1 = scanBeginOfLine p0 - | otherwise = scan p0 - where - keywords' = if lcKeywords opts - then map (map toLower) keywords - else keywords - mkKeyword s | s `elem` lowercaseKeywords = s - | otherwise = map toUpper s - - scan :: Lexer Token - scan p [] = Nothing - scan p ('/':'/':xs) - | clean opts - = let (com,rest) = span (/= '\n') xs - in advc' (2+length com) p scan rest - scan p ('-':'-':xs) | null xs || not (head xs `elem` "<>!?#@:%$^&") - = let (com,rest) = span (/= '\n') xs - in advc' (2+length com) p scan rest - scan p ('{':'-':xs) = advc' 2 p (ncomment scan) xs - scan p ('/':'*':xs) | clean opts = advc' 2 p (cleancomment scan) xs - scan p ('{' :xs) = advc' 1 p codescrap xs - scan p ('\CR':xs) = case xs of - '\LF':ys -> newl' p scanBeginOfLine ys --ms newline - _ -> newl' p scanBeginOfLine xs --mac newline - scan p ('\LF':xs) = newl' p scanBeginOfLine xs --unix newline - scan p (x:xs) | isSpace x = updPos' x p scan xs - scan p xs = Just (scan' xs) - where scan' ('.' :rs) = (reserved "." p, advc 1 p, rs) - scan' ('@' :rs) = (reserved "@" p, advc 1 p, rs) - scan' (',' :rs) = (reserved "," p, advc 1 p, rs) - scan' ('_' :rs) = (reserved "_" p, advc 1 p, rs) - scan' ('~' :rs) = (reserved "~" p, advc 1 p, rs) - scan' ('+' :rs) = (reserved "+" p, advc 1 p, rs) - scan' ('<' : '-' : rs) = (reserved "<-" p, advc 2 p, rs) - scan' ('<' : '=' : rs) = (reserved "<=" p, advc 2 p, rs) - scan' ('<' : '<' : '-' : rs) = (reserved "<<-" p, advc 3 p, rs) - scan' ('<' :rs) = (reserved "<" p, advc 1 p, rs) - scan' ('[' :rs) = (reserved "[" p, advc 1 p, rs) - scan' (']' :rs) = (reserved "]" p, advc 1 p, rs) - scan' ('(' :rs) = (reserved "(" p, advc 1 p, rs) - scan' (')' :rs) = (reserved ")" p, advc 1 p, rs) - -- scan' ('{' :rs) = (OBrace p, advc 1 p, rs) - -- scan' ('}' :rs) = (CBrace p, advc 1 p, rs) - - scan' ('\"' :rs) = let isOk c = c /= '"' && c /= '\n' - (str,rest) = span isOk rs - in if null rest || head rest /= '"' - then (errToken "unterminated string literal" p - , advc (1+length str) p,rest) - else (valueToken TkString str p, advc (2+length str) p, tail rest) - - scan' ('=' : '>' : rs) = (reserved "=>" p, advc 2 p, rs) - scan' ('=' :rs) = (reserved "=" p, advc 1 p, rs) - scan' (':':'=':rs) = (reserved ":=" p, advc 2 p, rs) - scan' (':':':':rs) = (reserved "::" p, advc 2 p, rs) - scan' ('∷':rs) = (reserved "::" p, advc 1 p, rs) -- recognize unicode double colons too - scan' (':' :rs) = (reserved ":" p, advc 1 p, rs) - scan' ('|' :rs) = (reserved "|" p, advc 1 p, rs) - - scan' ('/':'\\':rs) = (reserved "/\\" p, advc 2 p, rs) - scan' ('-':'>' :rs) = (reserved "->" p, advc 2 p, rs) - scan' ('-' :rs) = (reserved "-" p, advc 1 p, rs) - scan' ('*' :rs) = (reserved "*" p, advc 1 p, rs) - - scan' ('\'' :rs) | ocaml opts = -- note: ocaml type variables are encoded as 'TkTextnm' tokens - let (var,rest) = ident opts rs - str = '\'' : var - in (valueToken TkTextnm str p, advc (length str) p, rest) - - scan' (x:rs) | isLower x = let (var,rest) = ident opts rs - str = (x:var) - tok | str `elem` keywords' = reserved (mkKeyword str) - | otherwise = valueToken TkVarid str - in (tok p, advc (length var+1) p, rest) - | isUpper x = let (var,rest) = ident opts rs - str = (x:var) - tok | str `elem` keywords' = reserved (mkKeyword str) - | otherwise = valueToken TkConid str - in (tok p, advc (length var+1) p,rest) - | otherwise = (errToken ("unexpected character " ++ show x) p, advc 1 p, rs) - - scanBeginOfLine :: Lexer Token - scanBeginOfLine p ('{' : '-' : ' ' : 'L' : 'I' : 'N' : 'E' : ' ' : xs) - | isOkBegin rs && isOkEnd rs' - = scan (advc (8 + length r + 2 + length s + 4) p') (drop 4 rs') - | otherwise - = Just (errToken ("Invalid LINE pragma: " ++ show r) p, advc 8 p, xs) - where - (r,rs) = span isDigit xs - (s, rs') = span (/= '"') (drop 2 rs) - p' = Pos (read r - 1) (column p) s -- LINE pragma indicates the line number of the /next/ line! - - isOkBegin (' ' : '"' : _) = True - isOkBegin _ = False - - isOkEnd ('"' : ' ' : '-' : '}' : _) = True - isOkEnd _ = False - scanBeginOfLine p xs - = scan p xs - - -ident opts = span isValid - where isValid x = isAlphaNum x || x == '_' || - (not (clean opts) && x == '\'') || (clean opts && x == '`') - -lowercaseKeywords = ["loc","lhs", "inst", "optpragmas", "imports", "toplevel", "datablock", "recblock"] -keywords = lowercaseKeywords ++ - [ "DATA", "RECORD", "EXT", "ATTR", "SEM","TYPE", "USE", "INCLUDE" - , "EXTENDS" -- marcos - , "SET","DERIVING","FOR", "WRAPPER", "NOCATAS", "MAYBE", "EITHER", "MAP", "INTMAP" - , "PRAGMA", "SEMPRAGMA", "MODULE", "ATTACH", "UNIQUEREF", "INH", "SYN", "CHN" - , "AUGMENT", "AROUND", "MERGE", "AS", "SELF", "INTSET" - ] - -ncomment c p ('-':'}':xs) = advc' 2 p c xs -ncomment c p ('{':'-':xs) = advc' 2 p (ncomment (ncomment c)) xs -ncomment c p (x:xs) = updPos' x p (ncomment c) xs -ncomment c p [] = Just (errToken "unterminated nested comment" p, p,[]) - -cleancomment c p ('*':'/':xs) = advc' 2 p c xs -cleancomment c p ('/':'*':xs) = advc' 2 p (cleancomment (cleancomment c)) xs -cleancomment c p (x:xs) = updPos' x p (cleancomment c) xs -cleancomment c p [] = Just (errToken "unterminated nested comment" p, p,[]) - -codescrap p xs = let (p2,xs2,sc) = codescrap' 1 p xs - in case xs2 of - ('}':rest) -> Just (valueToken TkTextln sc p,advc 1 p2,rest) - _ -> Just (errToken "unterminated codescrap" p,p2,xs2) - - -codescrap' d p [] = (p,[],[]) -{- -codescrap' d p ('{':'{':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs - in (p2,xs2,'{':' ':sc) -codescrap' d p ('}':'}':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs - in (p2,xs2,'}':' ':sc) --} -codescrap' d p ('{':xs) = let (p2,xs2,sc) = advc' 1 p (codescrap' (d+1)) xs - in (p2,xs2,'{' : sc) -codescrap' d p ('}':xs) | d == 1 = (p,'}':xs,[]) - | otherwise = let (p2,xs2,sc) = advc' 1 p (codescrap' (d-1)) xs - in (p2,xs2,'}' : sc) -codescrap' d p (x :xs) = let (p2,xs2,sc) = updPos' x p (codescrap' d) xs - in (p2,xs2,x:sc) ---Literate Mode -scanLit xs = (fs, foldr insNL (const "") codeLns 1) - where insNL (n,line) r = \n1 -> replicate (n-n1) '\n' ++ line ++ r n - (fs,codeLns,_) = getBlocks ([1..] `zip` toLines xs) - getBlocks [] = ([],[],[]) - getBlocks xs = let (files1,txt1,r1) = getBlock xs - (files2,txt2,r2) = getBlocks r1 - in (files1++files2, txt1++txt2, r2) - - - getBlock = getLines . dropWhile comment - getLines [] = ([],[],[]) - getLines ((n,l):ls) | "\\begin{code}" `isPrefixOf` l = let (lns,rest) = codelines ls - in ([],lns,rest) - | "\\begin{Code}" `isPrefixOf` l = let (lns,rest) = codeLines ls - in ([],lns,rest) - | "\\IN{" `isPrefixOf` l = - let name = getName l - in ([name],[],ls) - | otherwise = getBlock ls - comment = not . ("\\" `isPrefixOf`) .snd - -toLines :: String -> [String] -toLines "" = [] -toLines s = let (l,s') = breakLine s - in l : toLines s' -breakLine xs = case xs of - '\CR' : ys -> case ys of - '\LF' : zs -> ([],zs) - _ -> ([],ys) - '\LF' : ys -> ([], ys) - x : ys -> let (l,s) = breakLine ys - in (x:l,s) - [] -> ([],[]) - -codelines [] = error "Unterminated literate code block" -codelines ((n,l):ls) | "\\end{code}" `isPrefixOf` l = ([],ls) - | otherwise = let (lns,r) = codelines ls - in ((n,l):lns,r) - -codeLines [] = error "Unterminated literate Code block" -codeLines ((n,l):ls) | "\\end{Code}" `isPrefixOf` l = ([],ls) - | otherwise = let (lns,r) = codeLines ls - in ((n,l):lns,r) - -getName l = case r of - ('}':_) -> nm - _ -> error $ "missing '}' in \\IN" - where (nm,r) = span (/='}') (drop 4 l) +{-# LANGUAGE MagicHash, UnboxedTuples, FlexibleInstances #-} +module Scanner where +import GHC.Prim +import TokenDef +import UU.Scanner.Position +import UU.Scanner.Token +import UU.Parsing(InputState(..),Either'(..)) +import Data.Maybe +import Data.List +import Data.Char +import UU.Scanner.GenToken +import Options (Options (..)) + +data Input = Input !Pos String (Maybe (Token, Input)) + +instance InputState Input Token Pos where + splitStateE input@(Input _ _ next) = + case next of + Nothing -> Right' input + Just (s, rest) -> Left' s rest + splitState (Input _ _ next) = + case next of + Nothing -> error "splitState on empty input" + Just (s, rest) -> (# s, rest #) + getPosition (Input pos _ next) = case next of + Just (s,_) -> position s + Nothing -> pos -- end of file + + +input :: Options -> Pos -> String -> Input +input opts pos inp = Input pos + inp + (case scan opts pos inp of + Nothing -> Nothing + Just (s,p,r) -> Just (s, input opts p r) + ) + +type Lexer s = Pos -> String -> Maybe (s,Pos,String) + +scan :: Options -> Lexer Token +scan opts p0 + | column p0 == 1 = scanBeginOfLine p0 + | otherwise = scan p0 + where + keywords' = if lcKeywords opts + then map (map toLower) keywords + else keywords + mkKeyword s | s `elem` lowercaseKeywords = s + | otherwise = map toUpper s + + scan :: Lexer Token + scan p [] = Nothing + scan p ('/':'/':xs) + | clean opts + = let (com,rest) = span (/= '\n') xs + in advc' (2+length com) p scan rest + scan p ('-':'-':xs) | null xs || not (head xs `elem` "<>!?#@:%$^&") + = let (com,rest) = span (/= '\n') xs + in advc' (2+length com) p scan rest + scan p ('{':'-':xs) = advc' 2 p (ncomment scan) xs + scan p ('/':'*':xs) | clean opts = advc' 2 p (cleancomment scan) xs + scan p ('{' :xs) = advc' 1 p codescrap xs + scan p ('\CR':xs) = case xs of + '\LF':ys -> newl' p scanBeginOfLine ys --ms newline + _ -> newl' p scanBeginOfLine xs --mac newline + scan p ('\LF':xs) = newl' p scanBeginOfLine xs --unix newline + scan p (x:xs) | isSpace x = updPos' x p scan xs + scan p xs = Just (scan' xs) + where scan' ('.' :rs) = (reserved "." p, advc 1 p, rs) + scan' ('@' :rs) = (reserved "@" p, advc 1 p, rs) + scan' (',' :rs) = (reserved "," p, advc 1 p, rs) + scan' ('_' :rs) = (reserved "_" p, advc 1 p, rs) + scan' ('~' :rs) = (reserved "~" p, advc 1 p, rs) + scan' ('+' :rs) = (reserved "+" p, advc 1 p, rs) + scan' ('<' : '-' : rs) = (reserved "<-" p, advc 2 p, rs) + scan' ('<' : '=' : rs) = (reserved "<=" p, advc 2 p, rs) + scan' ('<' : '<' : '-' : rs) = (reserved "<<-" p, advc 3 p, rs) + scan' ('<' :rs) = (reserved "<" p, advc 1 p, rs) + scan' ('[' :rs) = (reserved "[" p, advc 1 p, rs) + scan' (']' :rs) = (reserved "]" p, advc 1 p, rs) + scan' ('(' :rs) = (reserved "(" p, advc 1 p, rs) + scan' (')' :rs) = (reserved ")" p, advc 1 p, rs) + -- scan' ('{' :rs) = (OBrace p, advc 1 p, rs) + -- scan' ('}' :rs) = (CBrace p, advc 1 p, rs) + + scan' ('\"' :rs) = let isOk c = c /= '"' && c /= '\n' + (str,rest) = span isOk rs + in if null rest || head rest /= '"' + then (errToken "unterminated string literal" p + , advc (1+length str) p,rest) + else (valueToken TkString str p, advc (2+length str) p, tail rest) + + scan' ('=' : '>' : rs) = (reserved "=>" p, advc 2 p, rs) + scan' ('=' :rs) = (reserved "=" p, advc 1 p, rs) + scan' (':':'=':rs) = (reserved ":=" p, advc 2 p, rs) + scan' (':':':':rs) = (reserved "::" p, advc 2 p, rs) + scan' ('∷':rs) = (reserved "::" p, advc 1 p, rs) -- recognize unicode double colons too + scan' (':' :rs) = (reserved ":" p, advc 1 p, rs) + scan' ('|' :rs) = (reserved "|" p, advc 1 p, rs) + + scan' ('/':'\\':rs) = (reserved "/\\" p, advc 2 p, rs) + scan' ('-':'>' :rs) = (reserved "->" p, advc 2 p, rs) + scan' ('-' :rs) = (reserved "-" p, advc 1 p, rs) + scan' ('*' :rs) = (reserved "*" p, advc 1 p, rs) + + scan' ('\'' :rs) | ocaml opts = -- note: ocaml type variables are encoded as 'TkTextnm' tokens + let (var,rest) = ident opts rs + str = '\'' : var + in (valueToken TkTextnm str p, advc (length str) p, rest) + + scan' (x:rs) | isLower x = let (var,rest) = ident opts rs + str = (x:var) + tok | str `elem` keywords' = reserved (mkKeyword str) + | otherwise = valueToken TkVarid str + in (tok p, advc (length var+1) p, rest) + | isUpper x = let (var,rest) = ident opts rs + str = (x:var) + tok | str `elem` keywords' = reserved (mkKeyword str) + | otherwise = valueToken TkConid str + in (tok p, advc (length var+1) p,rest) + | otherwise = (errToken ("unexpected character " ++ show x) p, advc 1 p, rs) + + scanBeginOfLine :: Lexer Token + scanBeginOfLine p ('{' : '-' : ' ' : 'L' : 'I' : 'N' : 'E' : ' ' : xs) + | isOkBegin rs && isOkEnd rs' + = scan (advc (8 + length r + 2 + length s + 4) p') (drop 4 rs') + | otherwise + = Just (errToken ("Invalid LINE pragma: " ++ show r) p, advc 8 p, xs) + where + (r,rs) = span isDigit xs + (s, rs') = span (/= '"') (drop 2 rs) + p' = Pos (read r - 1) (column p) s -- LINE pragma indicates the line number of the /next/ line! + + isOkBegin (' ' : '"' : _) = True + isOkBegin _ = False + + isOkEnd ('"' : ' ' : '-' : '}' : _) = True + isOkEnd _ = False + scanBeginOfLine p xs + = scan p xs + + +ident opts = span isValid + where isValid x = isAlphaNum x || x == '_' || + (not (clean opts) && x == '\'') || (clean opts && x == '`') + +lowercaseKeywords = ["loc","lhs", "inst", "optpragmas", "imports", "toplevel", "datablock", "recblock"] +keywords = lowercaseKeywords ++ + [ "DATA", "RECORD", "EXT", "ATTR", "SEM","TYPE", "USE", "INCLUDE" + , "EXTENDS" -- marcos + , "SET","DERIVING","FOR", "WRAPPER", "NOCATAS", "MAYBE", "EITHER", "MAP", "INTMAP" + , "PRAGMA", "SEMPRAGMA", "MODULE", "ATTACH", "UNIQUEREF", "INH", "SYN", "CHN" + , "AUGMENT", "AROUND", "MERGE", "AS", "SELF", "INTSET" + ] + +ncomment c p ('-':'}':xs) = advc' 2 p c xs +ncomment c p ('{':'-':xs) = advc' 2 p (ncomment (ncomment c)) xs +ncomment c p (x:xs) = updPos' x p (ncomment c) xs +ncomment c p [] = Just (errToken "unterminated nested comment" p, p,[]) + +cleancomment c p ('*':'/':xs) = advc' 2 p c xs +cleancomment c p ('/':'*':xs) = advc' 2 p (cleancomment (cleancomment c)) xs +cleancomment c p (x:xs) = updPos' x p (cleancomment c) xs +cleancomment c p [] = Just (errToken "unterminated nested comment" p, p,[]) + +codescrap p xs = let (p2,xs2,sc) = codescrap' 1 p xs + in case xs2 of + ('}':rest) -> Just (valueToken TkTextln sc p,advc 1 p2,rest) + _ -> Just (errToken "unterminated codescrap" p,p2,xs2) + + +codescrap' d p [] = (p,[],[]) +{- +codescrap' d p ('{':'{':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs + in (p2,xs2,'{':' ':sc) +codescrap' d p ('}':'}':xs) = let (p2,xs2,sc) = advc' 2 p (codescrap' d) xs + in (p2,xs2,'}':' ':sc) +-} +codescrap' d p ('{':xs) = let (p2,xs2,sc) = advc' 1 p (codescrap' (d+1)) xs + in (p2,xs2,'{' : sc) +codescrap' d p ('}':xs) | d == 1 = (p,'}':xs,[]) + | otherwise = let (p2,xs2,sc) = advc' 1 p (codescrap' (d-1)) xs + in (p2,xs2,'}' : sc) +codescrap' d p (x :xs) = let (p2,xs2,sc) = updPos' x p (codescrap' d) xs + in (p2,xs2,x:sc) +--Literate Mode +scanLit xs = (fs, foldr insNL (const "") codeLns 1) + where insNL (n,line) r = \n1 -> replicate (n-n1) '\n' ++ line ++ r n + (fs,codeLns,_) = getBlocks ([1..] `zip` toLines xs) + getBlocks [] = ([],[],[]) + getBlocks xs = let (files1,txt1,r1) = getBlock xs + (files2,txt2,r2) = getBlocks r1 + in (files1++files2, txt1++txt2, r2) + + + getBlock = getLines . dropWhile comment + getLines [] = ([],[],[]) + getLines ((n,l):ls) | "\\begin{code}" `isPrefixOf` l = let (lns,rest) = codelines ls + in ([],lns,rest) + | "\\begin{Code}" `isPrefixOf` l = let (lns,rest) = codeLines ls + in ([],lns,rest) + | "\\IN{" `isPrefixOf` l = + let name = getName l + in ([name],[],ls) + | otherwise = getBlock ls + comment = not . ("\\" `isPrefixOf`) .snd + +toLines :: String -> [String] +toLines "" = [] +toLines s = let (l,s') = breakLine s + in l : toLines s' +breakLine xs = case xs of + '\CR' : ys -> case ys of + '\LF' : zs -> ([],zs) + _ -> ([],ys) + '\LF' : ys -> ([], ys) + x : ys -> let (l,s) = breakLine ys + in (x:l,s) + [] -> ([],[]) + +codelines [] = error "Unterminated literate code block" +codelines ((n,l):ls) | "\\end{code}" `isPrefixOf` l = ([],ls) + | otherwise = let (lns,r) = codelines ls + in ((n,l):lns,r) + +codeLines [] = error "Unterminated literate Code block" +codeLines ((n,l):ls) | "\\end{Code}" `isPrefixOf` l = ([],ls) + | otherwise = let (lns,r) = codeLines ls + in ((n,l):lns,r) + +getName l = case r of + ('}':_) -> nm + _ -> error $ "missing '}' in \\IN" + where (nm,r) = span (/='}') (drop 4 l) diff --git a/src/SequentialComputation.lhs b/src/SequentialComputation.lhs --- a/src/SequentialComputation.lhs +++ b/src/SequentialComputation.lhs @@ -1,391 +1,391 @@ -\begin{code} -module SequentialComputation (computeSequential,Vertex,Edge,Table) where -import SequentialTypes -import InterfacesRules -import CodeSyntax -import GrammarInfo - -import Control.Monad(when,unless) -import Control.Monad.ST(ST, runST) -import Data.Array(Array,(!),bounds) -import Data.Array.ST(STArray, newArray, readArray, writeArray, freeze) -import Data.Maybe(isJust,fromJust) -import Data.List(partition,(\\)) -import qualified Data.Set as Set -import qualified Data.Map as Map - -\end{code} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Collecting information} - -In the Data.Graph library, -a graph is represented as |Array Vertex [Vertex]|, -mapping each vertex to a list of adjacent vertices. -A |Vertex| is simply encoded by an |Int|. -So to test whether an edge |(x,y)| belongs to |g| -we can evaluate |y `elem` g!x| - -For more efficiency, we use Maps instead of lists. -Sets would also have done, but we also want to each edge to have a path as a witness. - -Moreover, as we will mostly be adding edges to the graph, -we use a mutable array. -If we want to use any of the library -functions, we can convert our representation by |fmap Map.keys . freeze|. - -\begin{code} -type Graph = Array Vertex [Vertex] -type MGraph = Array Vertex (Map.Map Vertex Path) -type MMGraph s = STArray s Vertex (Map.Map Vertex Path) - -singleStep :: (Vertex->Vertex->PathStep) -> Edge -> EdgePath -singleStep f e@(s,t) = (e, [f s t]) - -\end{code} - -We can add an edge to a graph, or remove it. These functions return -whether they did something (resp. addition or removal) or not. hasEdge -only checks whether a graph contains an edge or not. - -\begin{code} -addEdge :: MMGraph s -> EdgePath -> ST s Bool -addEdge graph ((s,t),p) - = do m <- readArray graph s - let b = not (Map.member t m) - when b (writeArray graph s (Map.insert t p m)) - return b - -hasEdge :: MMGraph s -> EdgePath -> ST s Bool -hasEdge graph ((s,t),_) - = do m <- readArray graph s - return (Map.member t m) -\end{code} - -The first step is to assign a number to all attributes, and a -different one to all attribute occurrences. We create an array mapping -the numbers to the information about the attribute occurrences -(|ruleTable|), so we can look up this information in $O(1)$ time. We -also build mappings from attributes to their occurrences (|tdsToTdp|) -and vice versa (|tdpToTds|). |LMH| indicates the division of the -attributes - an element |(l,m,h) `elem` LMH| means that vertices |i, l -<= i <= h| are attributes of the same nonterminal, with vertices |j, l -<= j < m| being inherited and |k, m <= k <= h| being synthesized -attributes. - -See the |SequentialTypes.Info| and |SequentialTypes.LMH| - -Then we collect the direct dependencies, using the integer -representations. This list of tuples (edges in the dependency graph) -all information that is collected is passed to a function that will -compute the interfaces and visit sub-sequences. We cannot do this -computation in AG, because mutable arrays require the ST monad, which -cannot be used inside AG. - -Now we can build a graph for attributes, and a graph for ao's, and add -the direct dependencies to the ao graph. Like Pennings we will call -the attribte graph Tds (transitive dependencies of symbols), and the -ao-graph Tdp (transitive dependencies of productions). Unlike him, we -will have only one Tds and one Tdp graph. In |STGraph|, we can lookup -outgoing edges in |O(1)| time, but looking up incoming edges will take -|O(e)| time, where |e| is the number of edges in the graph. As we will -be doing this quite often it is worthwhile to keep both Tdp and its -transposed version. The computation will involve both Tds and Tdp. It -treats specially. TODO elaborate on that. - -\begin{code} -type Tdp s = (MMGraph s, MMGraph s) -type Tds s = MMGraph s -type Comp s = (Tds s, Tdp s) -\end{code} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Generating IDS} - -As we insert edges into Tdp we keep it transitively closed, so every -time we add the edge $(s,t)$ to V, we also add the edges -$\{ (r,t) || (r,s) \in V \}$ and -$\{ (s,u) || (t,u) \in V \}$. - -\begin{code} -insertTdp :: Info -> Comp s -> EdgePath -> ST s () -insertTdp info comp@(_,(tdpN,tdpT)) e@((s,t),ee) -- how to insert an edge (s,t): - = do b <- hasEdge tdpN e -- if it's not yet present - unless b - (do rs <- readArray tdpT s -- find all sources r for an edge to s - us <- readArray tdpN t -- find all targets u for an edge from t - let edges = e :[ ((r,t),er++ee ) | (r,er) <- Map.toList rs ] - ++ [ ((s,u), ee++eu) | (u,eu) <- Map.toList us ] - ++ [ ((r,u),er++ee++eu) | (r,er) <- Map.toList rs, (u,eu) <- Map.toList us ] - mapM_ (addTdpEdge info comp) edges -- and add all of them, without having to bother about transitive closure anymore - ) -\end{code} - -Edges in |Tdp| can induce edges in |Tds|, so whenever we add -an edge, we also add the induced edge if necessary - -\begin{code} -addTdpEdge :: Info -> Comp s -> EdgePath -> ST s () -- how to add an edge (s,t) when not having to bother about the transitive closure: -addTdpEdge info comp@(_,(tdpN,tdpT)) e@((s,t),ee) - = do b <- addEdge tdpN e -- add it to the normal graph - when b -- if it was a new edge - (do addEdge tdpT ((t,s),ee) -- also add it to the transposed graph - let u = tdpToTds info ! s -- find the corresponding attributes... - v = tdpToTds info ! t - nonlocal = u /= -1 && v /= -1 - equalfield = isEqualField (ruleTable info ! s) (ruleTable info ! t) - when (nonlocal && equalfield) -- ...and when necessary... - (insertTds info comp ((u,v),ee)) -- ...insert it to the Tds graph - ) -\end{code} - -Inserting edges into |Tds| will insert edges between the occurrences -of the attributes into |Tdp|. - -\begin{code} -insertTds :: Info -> Comp s -> EdgePath -> ST s () -insertTds info comp@(tds,_) e@((u,v),ee) - = do b <- addEdge tds e - when b - (mapM_ (insertTdp info comp) [ ( (s,t), [AttrStep u v] ) - | s <- tdsToTdp info ! u - , not (getIsIn (ruleTable info ! s)) -- inherited at LHS, or synthesized at RHS - , t <- tdsToTdp info ! v - , getIsIn (ruleTable info ! t) -- synthesized at LHS, or inherited at RHS - , isEqualField (ruleTable info ! s) (ruleTable info ! t) - ] - ) - -\end{code} - -If we add the direct dependencies to the Tdp graph in the way above, the -Tds graph is filled with IDS. -Below is a way to only build up the Tdp graph, without reflect the changes in the Tds graph. - -\begin{code} -simpleInsert :: Tdp s -> EdgePath -> ST s () -simpleInsert tdp@(tdpN,tdpT) e@((s,t),ee) - = do b <- hasEdge tdpT ((t,s),undefined) - unless b (do rs <- readArray tdpT s - us <- readArray tdpN t - let edges = e :[ ((r,t),er++ee ) | (r,er) <- Map.toList rs ] - ++ [ ((s,u), ee++eu) | (u,eu) <- Map.toList us ] - ++ [ ((r,u),er++ee++eu) | (r,er) <- Map.toList rs, (u,eu) <- Map.toList us ] - mapM_ (addSimpleEdge tdp) edges - ) - -addSimpleEdge :: Tdp s -> EdgePath -> ST s () -addSimpleEdge (tdpN,tdpT) e@((s,t),ee) - = do b <- addEdge tdpN e - when b (do addEdge tdpT ((t,s),ee) - return () - ) -\end{code} - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Interfaces} - -In absence of cycles we can find the interfaces. We only take -attributes that are used. - -When an attribute has no incoming edges it can be computed. As the -emphasis is on incoming edges, we will work with the transposed Tds -graph. The funtion |used| indicates which vertices are included in the -interfaces. - -See modules Interfaces and InterfacesRules for more information. - -%format sem_IRoot_IRoot = "sem_{IRoot}" -%format sem_Interface_Interface = "sem_{Interface}" -%format sem_Interfaces_Cons = ":_{Interfaces}" -%format sem_Interfaces_Nil = "[]_{Interfaces}" -%format sem_Segments_Cons = ":_{Segments}" -%format sem_Segments_Nil = "[]_{Segments}" - -\begin{code} -makeInterfaces :: Info -> Graph -> T_IRoot -makeInterfaces info tds - = let interslist = reverse . makeInterface tds [] - mkSegments = foldr (sem_Segments_Cons . uncurry sem_Segment_Segment) sem_Segments_Nil . interslist - mkInter ((nt,cons),lmh) = sem_Interface_Interface nt cons (mkSegments lmh) - inters = foldr (sem_Interfaces_Cons . mkInter) sem_Interfaces_Nil (zip (nonts info) (lmh info)) - in sem_IRoot_IRoot inters -\end{code} - -The sinks of a graph are those vertices that have no outgoing -edges. We define a function that determines whether a vertex is a sink -if a set |del| of vertices had been removed from the graph. This means -that the attribute can be computed if all attributes in |del| have -been computed. - -\begin{code} -isSink :: Graph -> [Vertex] -> Vertex -> Bool -isSink graph del v = null (graph ! v \\ del) -\end{code} - -Now we can make interfaces by taking inherited sinks and synthesized -sinks alternatively. If there are no synthesized attributes at all, -generate an interface with one visit computing nothing. - -\begin{code} -makeInterface :: Graph -> [Vertex] -> LMH -> [([Vertex],[Vertex])] -makeInterface tds del (l,m,h) - | m > h = [([],[])] - | otherwise = let syn = filter (isSink tds del) ([m..h] \\ del) - del' = del ++ syn - inh = filter (isSink tds del') ([l..(m-1)] \\ del') - del'' = del' ++ inh - rest = makeInterface tds del'' (l,m,h) - in if null inh && null syn - then [] - else (inh,syn) : rest -\end{code} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Detecting of cycles} - -We only want to return s2i edges. - -\begin{code} -findCycles :: Info -> MGraph -> [EdgePaths] -findCycles info tds - = [ ((u,v),p1,p2) - | (l,m,h) <- lmh info -- for every nonterminal: [l..m-1] are inherited, [m..h] are synthesized - , v <- [m..h] -- for every synthesized attribute - , (u,p1) <- Map.toList (tds ! v) -- find dependent attributes... - , l <= u, u < m -- ...that are inherited... - , let mbp2 = Map.lookup v (tds ! u) -- ...and have a cycle back - , isJust mbp2 - , let p2 = fromJust mbp2 - ] - -findLocCycles :: MGraph -> [EdgePath] -findLocCycles tdp - = let (low, high) = bounds tdp - in [ ((u,u),p) - | u <- [low..high] - , (v,p) <- Map.toList (tdp ! u) - , v==u - ] - -findInstCycles :: [Edge] -> MGraph -> [EdgePath] -findInstCycles instToSynEdges tdp - = [ ((i,s), fromJust mbp) - | (i, s) <- instToSynEdges - , let mbp = Map.lookup i (tdp ! s) - , isJust mbp - ] -\end{code} - - - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Tying it together} - -\begin{code} -generateVisits :: Info -> MGraph -> MGraph -> [Edge] -> (CInterfaceMap, CVisitsMap, [Edge]) -generateVisits info tds tdp dpr - = let inters = makeInterfaces info (fmap Map.keys tds) - inhs = Inh_IRoot{ info_Inh_IRoot = info - , tdp_Inh_IRoot = fmap Map.keys tdp - , dpr_Inh_IRoot = dpr - } - iroot = wrap_IRoot inters inhs - in (inters_Syn_IRoot iroot, visits_Syn_IRoot iroot, edp_Syn_IRoot iroot) - -reportLocalCycle :: MGraph -> [EdgePath] -> [[Vertex]] -reportLocalCycle tds cyc - = fst (foldr f ([],Set.empty) (map (edgePathToEdgeRoute tds) cyc)) - where f ((x,_),p) res@(paths,syms) | Set.member x syms = res -- don't report a cyclic vertex if it appears on a path of an earlier reported one - | otherwise = (p:paths, Set.union syms (Set.fromList p)) - -reportCycle :: Info -> MGraph -> [EdgePaths] -> [EdgeRoutes] -reportCycle info tds cyc - = fst (foldr f ([],Set.empty) (map (edgePathsToEdgeRoutes tds) cyc)) - where f epp@((x,y),p1,p2) res@(paths,syms) | Set.member x syms && - Set.member y syms = res -- don't report mutually dependent vertices if both appear on paths reported earlier - | otherwise = (epp:paths, Set.union syms (Set.fromList (map tdp2tds (p1++p2)))) - tdp2tds (-2) = -2 - tdp2tds v = tdpToTds info ! v - -edgePathsToEdgeRoutes :: MGraph -> EdgePaths -> EdgeRoutes -edgePathsToEdgeRoutes tds (e,p1,p2) = ( e, pathToRoute tds p1, pathToRoute tds p2 ) - -edgePathToEdgeRoute :: MGraph -> EdgePath -> EdgeRoute -edgePathToEdgeRoute tds (e,p) = ( e, pathToRoute tds p ) - -pathToRoute :: MGraph -> Path -> Route -pathToRoute tds p = convertPath (expandAll p) - where expandAll :: Path -> Path - expandAll p | hasAttrStep p = expandAll (expandOne p) - | otherwise = p - expandOne :: Path -> Path - expandOne p = shortcut (concatMap expandStep p) - expandStep :: PathStep -> Path - expandStep (AttrStep u v) = fromJust (Map.lookup v (tds!u)) - expandStep x = [x] - convertPath :: Path -> Route - convertPath p = concatMap convertStep p - convertStep :: PathStep -> Route - convertStep (AtOcStep s t) = [s,t] - convertStep (AttrIndu s t) = [-2,-2] - -hasAttrStep :: Path -> Bool -hasAttrStep [] = False -hasAttrStep (AttrStep _ _ : _ ) = True -hasAttrStep (_ : xs) = hasAttrStep xs - -shortcut :: Eq a => [a] -> [a] -shortcut [] = [] -shortcut (x:xs) = x : shortcut (removeBefore x xs) - -removeBefore :: Eq a => a -> [a] -> [a] -removeBefore x ys = reverse (takeWhile (/=x) (reverse ys)) - - -isLocLoc :: Table CRule -> EdgePath -> Bool -isLocLoc rt ((s,t),_) = isLocal (rt ! s) && isLocal (rt ! t) - -- || (isInst (rt ! s) && isInst (rt ! t)) - -computeSequential :: Info -> [Edge] -> [Edge] -> CycleStatus -computeSequential info dpr instToSynEdges - = runST - (do let bigBounds = bounds (tdpToTds info) - smallBounds = bounds (tdsToTdp info) - (ll,es) = partition (isLocLoc (ruleTable info)) (map (singleStep AtOcStep) (dpr ++ instToSynEdges)) - tds <- newArray smallBounds Map.empty - tdpN <- newArray bigBounds Map.empty - tdpT <- newArray bigBounds Map.empty - let tdp = (tdpN,tdpT) - comp = (tds,tdp) - mapM_ (simpleInsert tdp) ll -- insert the local dependencies - tdp1 <- freeze tdpN - let cyc1 = findLocCycles tdp1 - if not (null cyc1) -- are they cyclic? - then do return (LocalCycle (reportLocalCycle undefined cyc1)) -- then report an error. - else do mapM_ (insertTdp info comp) es -- insert the other dependencies - tds2 <- freeze tds - let cyc2 = findCycles info tds2 - if not (null cyc2) -- are they cyclic? - then do return (DirectCycle (reportCycle info tds2 cyc2)) -- then report an error. - else do tdp2 <- freeze tdpN - let cyc4 = findInstCycles instToSynEdges tdp2 - if not (null cyc4) - then do return (InstCycle (reportLocalCycle tds2 cyc4)) -- then report an error. - else do let (cim,cvm,edp) = generateVisits info tds2 tdp2 dpr - mapM_ (insertTds info comp) (map (singleStep AttrIndu) edp) -- insert dependencies induced by visit scheduling - tds3 <- freeze tds - let cyc3 = findCycles info tds3 - if not (null cyc3) -- are they cyclic? - then return (InducedCycle cim (reportCycle info tds3 cyc3)) -- then report an error. - else do tdp3 <- freeze tdpN - let cyc5 = findInstCycles instToSynEdges tdp3 - if not (null cyc5) - then do return (InstCycle (reportLocalCycle tds3 cyc5)) -- then report an error. - else do return (CycleFree cim cvm) -- otherwise we succeed. - ) -\end{code} - - -\end{document} +\begin{code} +module SequentialComputation (computeSequential,Vertex,Edge,Table) where +import SequentialTypes +import InterfacesRules +import CodeSyntax +import GrammarInfo + +import Control.Monad(when,unless) +import Control.Monad.ST(ST, runST) +import Data.Array(Array,(!),bounds) +import Data.Array.ST(STArray, newArray, readArray, writeArray, freeze) +import Data.Maybe(isJust,fromJust) +import Data.List(partition,(\\)) +import qualified Data.Set as Set +import qualified Data.Map as Map + +\end{code} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Collecting information} + +In the Data.Graph library, +a graph is represented as |Array Vertex [Vertex]|, +mapping each vertex to a list of adjacent vertices. +A |Vertex| is simply encoded by an |Int|. +So to test whether an edge |(x,y)| belongs to |g| +we can evaluate |y `elem` g!x| + +For more efficiency, we use Maps instead of lists. +Sets would also have done, but we also want to each edge to have a path as a witness. + +Moreover, as we will mostly be adding edges to the graph, +we use a mutable array. +If we want to use any of the library +functions, we can convert our representation by |fmap Map.keys . freeze|. + +\begin{code} +type Graph = Array Vertex [Vertex] +type MGraph = Array Vertex (Map.Map Vertex Path) +type MMGraph s = STArray s Vertex (Map.Map Vertex Path) + +singleStep :: (Vertex->Vertex->PathStep) -> Edge -> EdgePath +singleStep f e@(s,t) = (e, [f s t]) + +\end{code} + +We can add an edge to a graph, or remove it. These functions return +whether they did something (resp. addition or removal) or not. hasEdge +only checks whether a graph contains an edge or not. + +\begin{code} +addEdge :: MMGraph s -> EdgePath -> ST s Bool +addEdge graph ((s,t),p) + = do m <- readArray graph s + let b = not (Map.member t m) + when b (writeArray graph s (Map.insert t p m)) + return b + +hasEdge :: MMGraph s -> EdgePath -> ST s Bool +hasEdge graph ((s,t),_) + = do m <- readArray graph s + return (Map.member t m) +\end{code} + +The first step is to assign a number to all attributes, and a +different one to all attribute occurrences. We create an array mapping +the numbers to the information about the attribute occurrences +(|ruleTable|), so we can look up this information in $O(1)$ time. We +also build mappings from attributes to their occurrences (|tdsToTdp|) +and vice versa (|tdpToTds|). |LMH| indicates the division of the +attributes - an element |(l,m,h) `elem` LMH| means that vertices |i, l +<= i <= h| are attributes of the same nonterminal, with vertices |j, l +<= j < m| being inherited and |k, m <= k <= h| being synthesized +attributes. + +See the |SequentialTypes.Info| and |SequentialTypes.LMH| + +Then we collect the direct dependencies, using the integer +representations. This list of tuples (edges in the dependency graph) +all information that is collected is passed to a function that will +compute the interfaces and visit sub-sequences. We cannot do this +computation in AG, because mutable arrays require the ST monad, which +cannot be used inside AG. + +Now we can build a graph for attributes, and a graph for ao's, and add +the direct dependencies to the ao graph. Like Pennings we will call +the attribte graph Tds (transitive dependencies of symbols), and the +ao-graph Tdp (transitive dependencies of productions). Unlike him, we +will have only one Tds and one Tdp graph. In |STGraph|, we can lookup +outgoing edges in |O(1)| time, but looking up incoming edges will take +|O(e)| time, where |e| is the number of edges in the graph. As we will +be doing this quite often it is worthwhile to keep both Tdp and its +transposed version. The computation will involve both Tds and Tdp. It +treats specially. TODO elaborate on that. + +\begin{code} +type Tdp s = (MMGraph s, MMGraph s) +type Tds s = MMGraph s +type Comp s = (Tds s, Tdp s) +\end{code} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Generating IDS} + +As we insert edges into Tdp we keep it transitively closed, so every +time we add the edge $(s,t)$ to V, we also add the edges +$\{ (r,t) || (r,s) \in V \}$ and +$\{ (s,u) || (t,u) \in V \}$. + +\begin{code} +insertTdp :: Info -> Comp s -> EdgePath -> ST s () +insertTdp info comp@(_,(tdpN,tdpT)) e@((s,t),ee) -- how to insert an edge (s,t): + = do b <- hasEdge tdpN e -- if it's not yet present + unless b + (do rs <- readArray tdpT s -- find all sources r for an edge to s + us <- readArray tdpN t -- find all targets u for an edge from t + let edges = e :[ ((r,t),er++ee ) | (r,er) <- Map.toList rs ] + ++ [ ((s,u), ee++eu) | (u,eu) <- Map.toList us ] + ++ [ ((r,u),er++ee++eu) | (r,er) <- Map.toList rs, (u,eu) <- Map.toList us ] + mapM_ (addTdpEdge info comp) edges -- and add all of them, without having to bother about transitive closure anymore + ) +\end{code} + +Edges in |Tdp| can induce edges in |Tds|, so whenever we add +an edge, we also add the induced edge if necessary + +\begin{code} +addTdpEdge :: Info -> Comp s -> EdgePath -> ST s () -- how to add an edge (s,t) when not having to bother about the transitive closure: +addTdpEdge info comp@(_,(tdpN,tdpT)) e@((s,t),ee) + = do b <- addEdge tdpN e -- add it to the normal graph + when b -- if it was a new edge + (do addEdge tdpT ((t,s),ee) -- also add it to the transposed graph + let u = tdpToTds info ! s -- find the corresponding attributes... + v = tdpToTds info ! t + nonlocal = u /= -1 && v /= -1 + equalfield = isEqualField (ruleTable info ! s) (ruleTable info ! t) + when (nonlocal && equalfield) -- ...and when necessary... + (insertTds info comp ((u,v),ee)) -- ...insert it to the Tds graph + ) +\end{code} + +Inserting edges into |Tds| will insert edges between the occurrences +of the attributes into |Tdp|. + +\begin{code} +insertTds :: Info -> Comp s -> EdgePath -> ST s () +insertTds info comp@(tds,_) e@((u,v),ee) + = do b <- addEdge tds e + when b + (mapM_ (insertTdp info comp) [ ( (s,t), [AttrStep u v] ) + | s <- tdsToTdp info ! u + , not (getIsIn (ruleTable info ! s)) -- inherited at LHS, or synthesized at RHS + , t <- tdsToTdp info ! v + , getIsIn (ruleTable info ! t) -- synthesized at LHS, or inherited at RHS + , isEqualField (ruleTable info ! s) (ruleTable info ! t) + ] + ) + +\end{code} + +If we add the direct dependencies to the Tdp graph in the way above, the +Tds graph is filled with IDS. +Below is a way to only build up the Tdp graph, without reflect the changes in the Tds graph. + +\begin{code} +simpleInsert :: Tdp s -> EdgePath -> ST s () +simpleInsert tdp@(tdpN,tdpT) e@((s,t),ee) + = do b <- hasEdge tdpT ((t,s),undefined) + unless b (do rs <- readArray tdpT s + us <- readArray tdpN t + let edges = e :[ ((r,t),er++ee ) | (r,er) <- Map.toList rs ] + ++ [ ((s,u), ee++eu) | (u,eu) <- Map.toList us ] + ++ [ ((r,u),er++ee++eu) | (r,er) <- Map.toList rs, (u,eu) <- Map.toList us ] + mapM_ (addSimpleEdge tdp) edges + ) + +addSimpleEdge :: Tdp s -> EdgePath -> ST s () +addSimpleEdge (tdpN,tdpT) e@((s,t),ee) + = do b <- addEdge tdpN e + when b (do addEdge tdpT ((t,s),ee) + return () + ) +\end{code} + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Interfaces} + +In absence of cycles we can find the interfaces. We only take +attributes that are used. + +When an attribute has no incoming edges it can be computed. As the +emphasis is on incoming edges, we will work with the transposed Tds +graph. The funtion |used| indicates which vertices are included in the +interfaces. + +See modules Interfaces and InterfacesRules for more information. + +%format sem_IRoot_IRoot = "sem_{IRoot}" +%format sem_Interface_Interface = "sem_{Interface}" +%format sem_Interfaces_Cons = ":_{Interfaces}" +%format sem_Interfaces_Nil = "[]_{Interfaces}" +%format sem_Segments_Cons = ":_{Segments}" +%format sem_Segments_Nil = "[]_{Segments}" + +\begin{code} +makeInterfaces :: Info -> Graph -> T_IRoot +makeInterfaces info tds + = let interslist = reverse . makeInterface tds [] + mkSegments = foldr (sem_Segments_Cons . uncurry sem_Segment_Segment) sem_Segments_Nil . interslist + mkInter ((nt,cons),lmh) = sem_Interface_Interface nt cons (mkSegments lmh) + inters = foldr (sem_Interfaces_Cons . mkInter) sem_Interfaces_Nil (zip (nonts info) (lmh info)) + in sem_IRoot_IRoot inters +\end{code} + +The sinks of a graph are those vertices that have no outgoing +edges. We define a function that determines whether a vertex is a sink +if a set |del| of vertices had been removed from the graph. This means +that the attribute can be computed if all attributes in |del| have +been computed. + +\begin{code} +isSink :: Graph -> [Vertex] -> Vertex -> Bool +isSink graph del v = null (graph ! v \\ del) +\end{code} + +Now we can make interfaces by taking inherited sinks and synthesized +sinks alternatively. If there are no synthesized attributes at all, +generate an interface with one visit computing nothing. + +\begin{code} +makeInterface :: Graph -> [Vertex] -> LMH -> [([Vertex],[Vertex])] +makeInterface tds del (l,m,h) + | m > h = [([],[])] + | otherwise = let syn = filter (isSink tds del) ([m..h] \\ del) + del' = del ++ syn + inh = filter (isSink tds del') ([l..(m-1)] \\ del') + del'' = del' ++ inh + rest = makeInterface tds del'' (l,m,h) + in if null inh && null syn + then [] + else (inh,syn) : rest +\end{code} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Detecting of cycles} + +We only want to return s2i edges. + +\begin{code} +findCycles :: Info -> MGraph -> [EdgePaths] +findCycles info tds + = [ ((u,v),p1,p2) + | (l,m,h) <- lmh info -- for every nonterminal: [l..m-1] are inherited, [m..h] are synthesized + , v <- [m..h] -- for every synthesized attribute + , (u,p1) <- Map.toList (tds ! v) -- find dependent attributes... + , l <= u, u < m -- ...that are inherited... + , let mbp2 = Map.lookup v (tds ! u) -- ...and have a cycle back + , isJust mbp2 + , let p2 = fromJust mbp2 + ] + +findLocCycles :: MGraph -> [EdgePath] +findLocCycles tdp + = let (low, high) = bounds tdp + in [ ((u,u),p) + | u <- [low..high] + , (v,p) <- Map.toList (tdp ! u) + , v==u + ] + +findInstCycles :: [Edge] -> MGraph -> [EdgePath] +findInstCycles instToSynEdges tdp + = [ ((i,s), fromJust mbp) + | (i, s) <- instToSynEdges + , let mbp = Map.lookup i (tdp ! s) + , isJust mbp + ] +\end{code} + + + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +\section{Tying it together} + +\begin{code} +generateVisits :: Info -> MGraph -> MGraph -> [Edge] -> (CInterfaceMap, CVisitsMap, [Edge]) +generateVisits info tds tdp dpr + = let inters = makeInterfaces info (fmap Map.keys tds) + inhs = Inh_IRoot{ info_Inh_IRoot = info + , tdp_Inh_IRoot = fmap Map.keys tdp + , dpr_Inh_IRoot = dpr + } + iroot = wrap_IRoot inters inhs + in (inters_Syn_IRoot iroot, visits_Syn_IRoot iroot, edp_Syn_IRoot iroot) + +reportLocalCycle :: MGraph -> [EdgePath] -> [[Vertex]] +reportLocalCycle tds cyc + = fst (foldr f ([],Set.empty) (map (edgePathToEdgeRoute tds) cyc)) + where f ((x,_),p) res@(paths,syms) | Set.member x syms = res -- don't report a cyclic vertex if it appears on a path of an earlier reported one + | otherwise = (p:paths, Set.union syms (Set.fromList p)) + +reportCycle :: Info -> MGraph -> [EdgePaths] -> [EdgeRoutes] +reportCycle info tds cyc + = fst (foldr f ([],Set.empty) (map (edgePathsToEdgeRoutes tds) cyc)) + where f epp@((x,y),p1,p2) res@(paths,syms) | Set.member x syms && + Set.member y syms = res -- don't report mutually dependent vertices if both appear on paths reported earlier + | otherwise = (epp:paths, Set.union syms (Set.fromList (map tdp2tds (p1++p2)))) + tdp2tds (-2) = -2 + tdp2tds v = tdpToTds info ! v + +edgePathsToEdgeRoutes :: MGraph -> EdgePaths -> EdgeRoutes +edgePathsToEdgeRoutes tds (e,p1,p2) = ( e, pathToRoute tds p1, pathToRoute tds p2 ) + +edgePathToEdgeRoute :: MGraph -> EdgePath -> EdgeRoute +edgePathToEdgeRoute tds (e,p) = ( e, pathToRoute tds p ) + +pathToRoute :: MGraph -> Path -> Route +pathToRoute tds p = convertPath (expandAll p) + where expandAll :: Path -> Path + expandAll p | hasAttrStep p = expandAll (expandOne p) + | otherwise = p + expandOne :: Path -> Path + expandOne p = shortcut (concatMap expandStep p) + expandStep :: PathStep -> Path + expandStep (AttrStep u v) = fromJust (Map.lookup v (tds!u)) + expandStep x = [x] + convertPath :: Path -> Route + convertPath p = concatMap convertStep p + convertStep :: PathStep -> Route + convertStep (AtOcStep s t) = [s,t] + convertStep (AttrIndu s t) = [-2,-2] + +hasAttrStep :: Path -> Bool +hasAttrStep [] = False +hasAttrStep (AttrStep _ _ : _ ) = True +hasAttrStep (_ : xs) = hasAttrStep xs + +shortcut :: Eq a => [a] -> [a] +shortcut [] = [] +shortcut (x:xs) = x : shortcut (removeBefore x xs) + +removeBefore :: Eq a => a -> [a] -> [a] +removeBefore x ys = reverse (takeWhile (/=x) (reverse ys)) + + +isLocLoc :: Table CRule -> EdgePath -> Bool +isLocLoc rt ((s,t),_) = isLocal (rt ! s) && isLocal (rt ! t) + -- || (isInst (rt ! s) && isInst (rt ! t)) + +computeSequential :: Info -> [Edge] -> [Edge] -> CycleStatus +computeSequential info dpr instToSynEdges + = runST + (do let bigBounds = bounds (tdpToTds info) + smallBounds = bounds (tdsToTdp info) + (ll,es) = partition (isLocLoc (ruleTable info)) (map (singleStep AtOcStep) (dpr ++ instToSynEdges)) + tds <- newArray smallBounds Map.empty + tdpN <- newArray bigBounds Map.empty + tdpT <- newArray bigBounds Map.empty + let tdp = (tdpN,tdpT) + comp = (tds,tdp) + mapM_ (simpleInsert tdp) ll -- insert the local dependencies + tdp1 <- freeze tdpN + let cyc1 = findLocCycles tdp1 + if not (null cyc1) -- are they cyclic? + then do return (LocalCycle (reportLocalCycle undefined cyc1)) -- then report an error. + else do mapM_ (insertTdp info comp) es -- insert the other dependencies + tds2 <- freeze tds + let cyc2 = findCycles info tds2 + if not (null cyc2) -- are they cyclic? + then do return (DirectCycle (reportCycle info tds2 cyc2)) -- then report an error. + else do tdp2 <- freeze tdpN + let cyc4 = findInstCycles instToSynEdges tdp2 + if not (null cyc4) + then do return (InstCycle (reportLocalCycle tds2 cyc4)) -- then report an error. + else do let (cim,cvm,edp) = generateVisits info tds2 tdp2 dpr + mapM_ (insertTds info comp) (map (singleStep AttrIndu) edp) -- insert dependencies induced by visit scheduling + tds3 <- freeze tds + let cyc3 = findCycles info tds3 + if not (null cyc3) -- are they cyclic? + then return (InducedCycle cim (reportCycle info tds3 cyc3)) -- then report an error. + else do tdp3 <- freeze tdpN + let cyc5 = findInstCycles instToSynEdges tdp3 + if not (null cyc5) + then do return (InstCycle (reportLocalCycle tds3 cyc5)) -- then report an error. + else do return (CycleFree cim cvm) -- otherwise we succeed. + ) +\end{code} + + +\end{document} diff --git a/src/SequentialTypes.hs b/src/SequentialTypes.hs --- a/src/SequentialTypes.hs +++ b/src/SequentialTypes.hs @@ -1,164 +1,164 @@ -module SequentialTypes where - -import CodeSyntax -import CommonTypes -import Data.Array(Array) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Maybe(fromJust) -import Data.List(partition) - -type Vertex = Int -data PathStep = AttrStep Vertex Vertex - | AtOcStep Vertex Vertex - | AttrIndu Vertex Vertex - deriving (Show, Eq) - -type Path = [PathStep] -type Route = [Vertex] - -type Edge = (Int,Int) -type EdgePath = (Edge,Path) -type EdgePaths = (Edge,Path,Path) -type EdgeRoute = (Edge,Route) -type EdgeRoutes= (Edge,Route,Route) - -type Table a = Array Vertex a - - -data ChildVisit = ChildVisit Identifier Identifier Int [Vertex] [Vertex] deriving (Eq,Show) -- field, rhs nt, visit nr., inh, syn -data NTAttr = NTAInh NontermIdent Identifier Type -- nt, attribute, type - | NTASyn NontermIdent Identifier Type -- nt, attribute, type - deriving Show - -getNtaNameType :: NTAttr -> (Identifier, Type) -getNtaNameType (NTAInh _ name tp) = (name,tp) -getNtaNameType (NTASyn _ name tp) = (name,tp) - -getAttr :: CRule -> Identifier -getAttr (CRule name _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = name -getAttr _ = error "Only defined for CRule" -getIsIn :: CRule -> Bool -getIsIn (CRule _ ii _ _ _ _ _ _ _ _ _ _ _ _ _ _) = ii -getIsIn _ = error "Only defined for CRule" -getHasCode :: CRule -> Bool -getHasCode (CRule _ _ hc _ _ _ _ _ _ _ _ _ _ _ _ _) = hc -getHasCode _ = error "Only defined for CRule" -getLhsNt :: CRule -> NontermIdent -getLhsNt (CRule _ _ _ nt _ _ _ _ _ _ _ _ _ _ _ _) = nt -getLhsNt _ = error "Only defined for CRule" -getCon :: CRule -> ConstructorIdent -getCon (CRule _ _ _ _ con _ _ _ _ _ _ _ _ _ _ _) = con -getCon _ = error "Only defined for CRule" -getField :: CRule -> Identifier -getField (CRule _ _ _ _ _ field _ _ _ _ _ _ _ _ _ _) = field -getField _ = error "Only defined for CRule" -getRhsNt :: CRule -> Maybe NontermIdent -getRhsNt (CRule _ _ _ _ _ _ childnt _ _ _ _ _ _ _ _ _) = childnt -getRhsNt _ = error "Only defined for CRule" -getType :: CRule -> Maybe Type -getType (CRule _ _ _ _ _ _ _ tp _ _ _ _ _ _ _ _) = tp -getType _ = error "Only defined for CRule" -getDefines :: CRule -> Map Int (Identifier, Identifier, Maybe Type) -getDefines (CRule _ _ _ _ _ _ _ _ _ _ defines _ _ _ _ _) = defines -getDefines _ = error "Only defined for CRule" -getUses :: CRule -> Set (Identifier, Identifier) -getUses (CRule _ _ _ _ _ _ _ _ _ _ _ _ _ uses _ _) = uses -getUses _ = error "Only defined for CRule" -getExplicit :: CRule -> Bool -getExplicit (CRule _ _ _ _ _ _ _ _ _ _ _ _ _ _ expl _) = expl -getExplicit _ = error "Only defined for CRule" - -isLocal, isInst, isLhs, isRhs, isSyn, isInh, hasCode :: CRule -> Bool -isLocal = (_LOC==) . getField -isInst = (_INST==) . getField -isLhs = (_LHS==) . getField -isRhs cr = not (isLhs cr || isLocal cr) -isSyn cr | isLocal cr = False - | getIsIn cr = isRhs cr - | otherwise = isLhs cr -isInh = not . isSyn -hasCode cr = isLocal cr || (isLhs cr && isInh cr) || (isRhs cr && isSyn cr) - -isEqualField, isDifferentField, isEqualCon, isRhsOfSameCon :: CRule -> CRule -> Bool -isEqualField a b = isEqualCon a b && getField a == getField b -isDifferentField a b = isEqualCon a b && getField a /= getField b -isEqualCon a b = getLhsNt a == getLhsNt b && getCon a == getCon b -isRhsOfSameCon a b = isEqualCon a b && isRhs a && isRhs b - -isSynAttr, isInhAttr :: NTAttr -> Bool -isSynAttr (NTAInh _ _ _) = False -isSynAttr (NTASyn _ _ _) = True -isInhAttr = not . isSynAttr - -ntattr :: CRule -> Maybe NTAttr -ntattr cr | isLocal cr = Nothing - | isInst cr = Nothing -- an inst definition is just considered as a local attribute definition - | otherwise = let at = if isSyn cr then NTASyn else NTAInh - getNt cr' = if isRhs cr' then fromJust (getRhsNt cr') else getLhsNt cr' - in Just (at (getNt cr) (getAttr cr) (fromJust (getType cr))) - -cRuleLhsInh :: Identifier -> NontermIdent -> ConstructorIdent -> Type -> CRule -cRuleLhsInh attr nt con tp = CRule attr True False nt con _LHS Nothing (Just tp) (error "cRuleLhsInh") [] Map.empty False "" Set.empty False Nothing -cRuleTerminal :: Identifier -> NontermIdent -> ConstructorIdent -> Type -> CRule -cRuleTerminal attr nt con tp = CRule attr True False nt con _LOC Nothing (Just tp) (error ("cRuleTerminal: " ++ show (attr, nt, con, tp))) [] Map.empty False "" Set.empty False Nothing -cRuleRhsSyn :: Identifier -> NontermIdent -> ConstructorIdent -> Type -> Identifier -> NontermIdent -> CRule -cRuleRhsSyn attr nt con tp field childnt = CRule attr True False nt con field (Just childnt) (Just tp) (error ("cRuleRhsSyn: " ++ show (attr, nt, con, tp, field))) [] Map.empty False "" Set.empty False Nothing - -defaultRule :: Identifier -> NontermIdent -> ConstructorIdent -> Identifier -> CRule -defaultRule attr nt con field = CRule attr (er 1) (er 2) nt con field (er 3) (er 4) (er 5) (er 6) (er 7) (er 8) (er 9) (er 10) False Nothing - where er :: Int -> a - er i = error ("Default rule has no code " ++ show i) - -instance Eq CRule where - a == b = getAttr a == getAttr b && isEqualField a b -instance Ord CRule where - compare a b = compare (getLhsNt a) (getLhsNt b) - >/< compare (getCon a) (getCon b) - >/< compare (getField a) (getField b) - >/< compare (getAttr a) (getAttr b) -instance Eq NTAttr where - (NTAInh _ _ _) == (NTASyn _ _ _) = False - (NTASyn _ _ _) == (NTAInh _ _ _) = False - (NTAInh nt name _) == (NTAInh nt' name' _) = nt == nt' && name == name' - (NTASyn nt name _) == (NTASyn nt' name' _) = nt == nt' && name == name' -instance Ord NTAttr where - compare (NTAInh _ _ _) (NTASyn _ _ _) = LT - compare (NTASyn _ _ _) (NTAInh _ _ _) = GT - compare (NTAInh nt name _) (NTAInh nt' name' _) = compare nt nt' >/< compare name name' - compare (NTASyn nt name _) (NTASyn nt' name' _) = compare nt nt' >/< compare name name' - -eqCRuleDefines :: CRule -> CRule -> Bool -eqCRuleDefines a b - = Map.keys (getDefines a) == Map.keys (getDefines b) - -(>/<) :: Ordering -> Ordering -> Ordering -EQ >/< b = b -a >/< _ = a - - -eqClasses :: (a -> a -> Bool) -> [a] -> [[a]] -eqClasses _ [] = [] -eqClasses p (a:as) = let (isA,rest) = partition (p a) as - in (a:isA):eqClasses p rest - -lhsshow :: Options -> NTAttr -> String -lhsshow opts (NTAInh _ attr _) = lhsname opts True attr -lhsshow opts (NTASyn _ attr _) = lhsname opts False attr - -rhsshow :: Options -> Identifier -> NTAttr -> String -rhsshow opts field (NTAInh _ attr _) = attrname opts False field attr -rhsshow opts field (NTASyn _ attr _) = attrname opts True field attr - -prettyCRule :: CRule -> String -prettyCRule cr - = let descr | isLocal cr = "local attribute " ++ show (getAttr cr) - | otherwise = (if isSyn cr then "synthesized " else "inherited ") - ++ "attribute " - ++ (if isRhs cr then show (getField cr) ++ "." else "") - ++ (if isLhs cr then "lhs." else "") - ++ (show (getAttr cr)) - in show (getLhsNt cr) ++ "." ++ show (getCon cr) ++ ", " ++ descr - +module SequentialTypes where + +import CodeSyntax +import CommonTypes +import Data.Array(Array) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Maybe(fromJust) +import Data.List(partition) + +type Vertex = Int +data PathStep = AttrStep Vertex Vertex + | AtOcStep Vertex Vertex + | AttrIndu Vertex Vertex + deriving (Show, Eq) + +type Path = [PathStep] +type Route = [Vertex] + +type Edge = (Int,Int) +type EdgePath = (Edge,Path) +type EdgePaths = (Edge,Path,Path) +type EdgeRoute = (Edge,Route) +type EdgeRoutes= (Edge,Route,Route) + +type Table a = Array Vertex a + + +data ChildVisit = ChildVisit Identifier Identifier Int [Vertex] [Vertex] deriving (Eq,Show) -- field, rhs nt, visit nr., inh, syn +data NTAttr = NTAInh NontermIdent Identifier Type -- nt, attribute, type + | NTASyn NontermIdent Identifier Type -- nt, attribute, type + deriving Show + +getNtaNameType :: NTAttr -> (Identifier, Type) +getNtaNameType (NTAInh _ name tp) = (name,tp) +getNtaNameType (NTASyn _ name tp) = (name,tp) + +getAttr :: CRule -> Identifier +getAttr (CRule name _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) = name +getAttr _ = error "Only defined for CRule" +getIsIn :: CRule -> Bool +getIsIn (CRule _ ii _ _ _ _ _ _ _ _ _ _ _ _ _ _) = ii +getIsIn _ = error "Only defined for CRule" +getHasCode :: CRule -> Bool +getHasCode (CRule _ _ hc _ _ _ _ _ _ _ _ _ _ _ _ _) = hc +getHasCode _ = error "Only defined for CRule" +getLhsNt :: CRule -> NontermIdent +getLhsNt (CRule _ _ _ nt _ _ _ _ _ _ _ _ _ _ _ _) = nt +getLhsNt _ = error "Only defined for CRule" +getCon :: CRule -> ConstructorIdent +getCon (CRule _ _ _ _ con _ _ _ _ _ _ _ _ _ _ _) = con +getCon _ = error "Only defined for CRule" +getField :: CRule -> Identifier +getField (CRule _ _ _ _ _ field _ _ _ _ _ _ _ _ _ _) = field +getField _ = error "Only defined for CRule" +getRhsNt :: CRule -> Maybe NontermIdent +getRhsNt (CRule _ _ _ _ _ _ childnt _ _ _ _ _ _ _ _ _) = childnt +getRhsNt _ = error "Only defined for CRule" +getType :: CRule -> Maybe Type +getType (CRule _ _ _ _ _ _ _ tp _ _ _ _ _ _ _ _) = tp +getType _ = error "Only defined for CRule" +getDefines :: CRule -> Map Int (Identifier, Identifier, Maybe Type) +getDefines (CRule _ _ _ _ _ _ _ _ _ _ defines _ _ _ _ _) = defines +getDefines _ = error "Only defined for CRule" +getUses :: CRule -> Set (Identifier, Identifier) +getUses (CRule _ _ _ _ _ _ _ _ _ _ _ _ _ uses _ _) = uses +getUses _ = error "Only defined for CRule" +getExplicit :: CRule -> Bool +getExplicit (CRule _ _ _ _ _ _ _ _ _ _ _ _ _ _ expl _) = expl +getExplicit _ = error "Only defined for CRule" + +isLocal, isInst, isLhs, isRhs, isSyn, isInh, hasCode :: CRule -> Bool +isLocal = (_LOC==) . getField +isInst = (_INST==) . getField +isLhs = (_LHS==) . getField +isRhs cr = not (isLhs cr || isLocal cr) +isSyn cr | isLocal cr = False + | getIsIn cr = isRhs cr + | otherwise = isLhs cr +isInh = not . isSyn +hasCode cr = isLocal cr || (isLhs cr && isInh cr) || (isRhs cr && isSyn cr) + +isEqualField, isDifferentField, isEqualCon, isRhsOfSameCon :: CRule -> CRule -> Bool +isEqualField a b = isEqualCon a b && getField a == getField b +isDifferentField a b = isEqualCon a b && getField a /= getField b +isEqualCon a b = getLhsNt a == getLhsNt b && getCon a == getCon b +isRhsOfSameCon a b = isEqualCon a b && isRhs a && isRhs b + +isSynAttr, isInhAttr :: NTAttr -> Bool +isSynAttr (NTAInh _ _ _) = False +isSynAttr (NTASyn _ _ _) = True +isInhAttr = not . isSynAttr + +ntattr :: CRule -> Maybe NTAttr +ntattr cr | isLocal cr = Nothing + | isInst cr = Nothing -- an inst definition is just considered as a local attribute definition + | otherwise = let at = if isSyn cr then NTASyn else NTAInh + getNt cr' = if isRhs cr' then fromJust (getRhsNt cr') else getLhsNt cr' + in Just (at (getNt cr) (getAttr cr) (fromJust (getType cr))) + +cRuleLhsInh :: Identifier -> NontermIdent -> ConstructorIdent -> Type -> CRule +cRuleLhsInh attr nt con tp = CRule attr True False nt con _LHS Nothing (Just tp) (error "cRuleLhsInh") [] Map.empty False "" Set.empty False Nothing +cRuleTerminal :: Identifier -> NontermIdent -> ConstructorIdent -> Type -> CRule +cRuleTerminal attr nt con tp = CRule attr True False nt con _LOC Nothing (Just tp) (error ("cRuleTerminal: " ++ show (attr, nt, con, tp))) [] Map.empty False "" Set.empty False Nothing +cRuleRhsSyn :: Identifier -> NontermIdent -> ConstructorIdent -> Type -> Identifier -> NontermIdent -> CRule +cRuleRhsSyn attr nt con tp field childnt = CRule attr True False nt con field (Just childnt) (Just tp) (error ("cRuleRhsSyn: " ++ show (attr, nt, con, tp, field))) [] Map.empty False "" Set.empty False Nothing + +defaultRule :: Identifier -> NontermIdent -> ConstructorIdent -> Identifier -> CRule +defaultRule attr nt con field = CRule attr (er 1) (er 2) nt con field (er 3) (er 4) (er 5) (er 6) (er 7) (er 8) (er 9) (er 10) False Nothing + where er :: Int -> a + er i = error ("Default rule has no code " ++ show i) + +instance Eq CRule where + a == b = getAttr a == getAttr b && isEqualField a b +instance Ord CRule where + compare a b = compare (getLhsNt a) (getLhsNt b) + >/< compare (getCon a) (getCon b) + >/< compare (getField a) (getField b) + >/< compare (getAttr a) (getAttr b) +instance Eq NTAttr where + (NTAInh _ _ _) == (NTASyn _ _ _) = False + (NTASyn _ _ _) == (NTAInh _ _ _) = False + (NTAInh nt name _) == (NTAInh nt' name' _) = nt == nt' && name == name' + (NTASyn nt name _) == (NTASyn nt' name' _) = nt == nt' && name == name' +instance Ord NTAttr where + compare (NTAInh _ _ _) (NTASyn _ _ _) = LT + compare (NTASyn _ _ _) (NTAInh _ _ _) = GT + compare (NTAInh nt name _) (NTAInh nt' name' _) = compare nt nt' >/< compare name name' + compare (NTASyn nt name _) (NTASyn nt' name' _) = compare nt nt' >/< compare name name' + +eqCRuleDefines :: CRule -> CRule -> Bool +eqCRuleDefines a b + = Map.keys (getDefines a) == Map.keys (getDefines b) + +(>/<) :: Ordering -> Ordering -> Ordering +EQ >/< b = b +a >/< _ = a + + +eqClasses :: (a -> a -> Bool) -> [a] -> [[a]] +eqClasses _ [] = [] +eqClasses p (a:as) = let (isA,rest) = partition (p a) as + in (a:isA):eqClasses p rest + +lhsshow :: Options -> NTAttr -> String +lhsshow opts (NTAInh _ attr _) = lhsname opts True attr +lhsshow opts (NTASyn _ attr _) = lhsname opts False attr + +rhsshow :: Options -> Identifier -> NTAttr -> String +rhsshow opts field (NTAInh _ attr _) = attrname opts False field attr +rhsshow opts field (NTASyn _ attr _) = attrname opts True field attr + +prettyCRule :: CRule -> String +prettyCRule cr + = let descr | isLocal cr = "local attribute " ++ show (getAttr cr) + | otherwise = (if isSyn cr then "synthesized " else "inherited ") + ++ "attribute " + ++ (if isRhs cr then show (getField cr) ++ "." else "") + ++ (if isLhs cr then "lhs." else "") + ++ (show (getAttr cr)) + in show (getLhsNt cr) ++ "." ++ show (getCon cr) ++ ", " ++ descr + diff --git a/src/TokenDef.hs b/src/TokenDef.hs --- a/src/TokenDef.hs +++ b/src/TokenDef.hs @@ -1,86 +1,86 @@ -{-# LANGUAGE MagicHash, - UnboxedTuples, FlexibleInstances #-} - -module TokenDef where - -import UU.Scanner.Token -import UU.Scanner.GenToken -import UU.Scanner.Position -import UU.Parsing.MachineInterface(Symbol(..)) -import Data.Char(isPrint,ord) -import HsToken -import CommonTypes - -instance Symbol Token where - deleteCost (Reserved key _) = case key of - "DATA" -> 7# - "EXT" -> 7# - "ATTR" -> 7# - "SEM" -> 7# - "USE" -> 7# - "INCLUDE" -> 7# - _ -> 5# - deleteCost (ValToken v _ _) = case v of - TkError -> 0# - _ -> 5# - -tokensToStrings :: [HsToken] -> [(Pos,String)] -tokensToStrings - = map tokenToString - -tokenToString :: HsToken -> (Pos, String) -tokenToString tk - = case tk of - AGLocal var pos _ -> (pos, "@" ++ getName var) - AGField field attr pos _ -> (pos, "@" ++ getName field ++ "." ++ getName attr) - HsToken value pos -> (pos, value) - CharToken value pos -> (pos, show value) - StrToken value pos -> (pos, show value) - Err mesg pos -> (pos, " ***" ++ mesg ++ "*** ") - -showTokens :: [(Pos,String)] -> [String] -showTokens [] = [] -showTokens xs = map showLine . shiftLeft . getLines $ xs - -getLines :: [(Pos, a)] -> [[(Pos, a)]] -getLines [] = [] -getLines ((p,t):xs) = let (txs,rest) = span sameLine xs - sameLine (q,_) = line p == line q - in ((p,t):txs) : getLines rest - -shiftLeft :: [[(Pos, a)]] -> [[(Pos, a)]] -shiftLeft lns = let sh = let m = minimum . checkEmpty . filter (>=1) . map (column.fst.head) $ lns - checkEmpty [] = [1] - checkEmpty x = x - in if m >= 1 then m-1 else 0 - shift (p,t) = (if column p >= 1 then case p of (Pos l c f) -> Pos l (c - sh) f else p, t) - in map (map shift) lns - -showLine :: [(Pos, [Char])] -> [Char] -showLine ts = let f (p,t) r = let ct = column p - in \c -> spaces (ct-c) ++ t ++ r (length t+ct) - spaces x | x < 0 = "" - | otherwise = replicate x ' ' - in foldr f (const "") ts 1 - -showStrShort :: String -> String -showStrShort xs = "\"" ++ concatMap f xs ++ "\"" - where f '"' = "\\\"" - f x = showCharShort' x - -showCharShort :: Char -> String -showCharShort '\'' = "'" ++ "\\'" ++ "'" -showCharShort c = "'" ++ showCharShort' c ++ "'" - -showCharShort' :: Char -> String -showCharShort' '\a' = "\\a" -showCharShort' '\b' = "\\b" -showCharShort' '\t' = "\\t" -showCharShort' '\n' = "\\n" -showCharShort' '\r' = "\\r" -showCharShort' '\f' = "\\f" -showCharShort' '\v' = "\\v" -showCharShort' '\\' = "\\\\" -showCharShort' x | isPrint x = [x] - | otherwise = '\\' : show (ord x) - +{-# LANGUAGE MagicHash, + UnboxedTuples, FlexibleInstances #-} + +module TokenDef where + +import UU.Scanner.Token +import UU.Scanner.GenToken +import UU.Scanner.Position +import UU.Parsing.MachineInterface(Symbol(..)) +import Data.Char(isPrint,ord) +import HsToken +import CommonTypes + +instance Symbol Token where + deleteCost (Reserved key _) = case key of + "DATA" -> 7# + "EXT" -> 7# + "ATTR" -> 7# + "SEM" -> 7# + "USE" -> 7# + "INCLUDE" -> 7# + _ -> 5# + deleteCost (ValToken v _ _) = case v of + TkError -> 0# + _ -> 5# + +tokensToStrings :: [HsToken] -> [(Pos,String)] +tokensToStrings + = map tokenToString + +tokenToString :: HsToken -> (Pos, String) +tokenToString tk + = case tk of + AGLocal var pos _ -> (pos, "@" ++ getName var) + AGField field attr pos _ -> (pos, "@" ++ getName field ++ "." ++ getName attr) + HsToken value pos -> (pos, value) + CharToken value pos -> (pos, show value) + StrToken value pos -> (pos, show value) + Err mesg pos -> (pos, " ***" ++ mesg ++ "*** ") + +showTokens :: [(Pos,String)] -> [String] +showTokens [] = [] +showTokens xs = map showLine . shiftLeft . getLines $ xs + +getLines :: [(Pos, a)] -> [[(Pos, a)]] +getLines [] = [] +getLines ((p,t):xs) = let (txs,rest) = span sameLine xs + sameLine (q,_) = line p == line q + in ((p,t):txs) : getLines rest + +shiftLeft :: [[(Pos, a)]] -> [[(Pos, a)]] +shiftLeft lns = let sh = let m = minimum . checkEmpty . filter (>=1) . map (column.fst.head) $ lns + checkEmpty [] = [1] + checkEmpty x = x + in if m >= 1 then m-1 else 0 + shift (p,t) = (if column p >= 1 then case p of (Pos l c f) -> Pos l (c - sh) f else p, t) + in map (map shift) lns + +showLine :: [(Pos, [Char])] -> [Char] +showLine ts = let f (p,t) r = let ct = column p + in \c -> spaces (ct-c) ++ t ++ r (length t+ct) + spaces x | x < 0 = "" + | otherwise = replicate x ' ' + in foldr f (const "") ts 1 + +showStrShort :: String -> String +showStrShort xs = "\"" ++ concatMap f xs ++ "\"" + where f '"' = "\\\"" + f x = showCharShort' x + +showCharShort :: Char -> String +showCharShort '\'' = "'" ++ "\\'" ++ "'" +showCharShort c = "'" ++ showCharShort' c ++ "'" + +showCharShort' :: Char -> String +showCharShort' '\a' = "\\a" +showCharShort' '\b' = "\\b" +showCharShort' '\t' = "\\t" +showCharShort' '\n' = "\\n" +showCharShort' '\r' = "\\r" +showCharShort' '\f' = "\\f" +showCharShort' '\v' = "\\v" +showCharShort' '\\' = "\\\\" +showCharShort' x | isPrint x = [x] + | otherwise = '\\' : show (ord x) + diff --git a/src/UU/UUAGC.hs b/src/UU/UUAGC.hs --- a/src/UU/UUAGC.hs +++ b/src/UU/UUAGC.hs @@ -1,12 +1,12 @@ -module UU.UUAGC (uuagc, uuagcMain, compile, module Options) where - -import Ag (uuagcLib, uuagcExe, compile) -import Options - -import System.Exit (ExitCode(..)) - -uuagc :: [String] -> FilePath -> IO (ExitCode, [FilePath]) -uuagc = uuagcLib - -uuagcMain :: IO () +module UU.UUAGC (uuagc, uuagcMain, compile, module Options) where + +import Ag (uuagcLib, uuagcExe, compile) +import Options + +import System.Exit (ExitCode(..)) + +uuagc :: [String] -> FilePath -> IO (ExitCode, [FilePath]) +uuagc = uuagcLib + +uuagcMain :: IO () uuagcMain = uuagcExe diff --git a/src/UU/UUAGC/Version.hs b/src/UU/UUAGC/Version.hs --- a/src/UU/UUAGC/Version.hs +++ b/src/UU/UUAGC/Version.hs @@ -1,4 +1,4 @@ --- | Get current version of UUAGC -module UU.UUAGC.Version(version) where - -import Paths_uuagc(version) +-- | Get current version of UUAGC +module UU.UUAGC.Version(version) where + +import Paths_uuagc(version) diff --git a/uuagc.cabal b/uuagc.cabal --- a/uuagc.cabal +++ b/uuagc.cabal @@ -1,124 +1,127 @@ -cabal-version: >= 1.10 -build-type: Custom -name: uuagc -version: 0.9.53.1 -license: BSD3 -license-file: LICENSE -maintainer: Jeroen Bransen -homepage: http://www.cs.uu.nl/wiki/HUT/WebHome -description: Generates Haskell files from an attribute grammar specification -synopsis: Attribute Grammar System of Universiteit Utrecht -category: Development -stability: Stable -copyright: Universiteit Utrecht -author: Software Technology at Universiteit Utrecht -bug-reports: hut-developers@cs.uu.nl -tested-with: GHC >= 6.12 -extra-source-files: README -extra-source-files: uuagc_options -extra-source-files: src-ag/*.ag -extra-source-files: src-ag/LOAG/*.ag - --- This flag will be set by Setup.hs, use --- cabal configure --ghc-options="-DEXTERNAL_UUAGC" -flag bootstrap_external - description: Use an external uuagc executable for bootstrapping - default: False - manual: True - -flag with-loag - description: Use MiniSat as external SAT-solver to schedule all Linear Ordered AGs - default: False - manual: True - -custom-setup - setup-depends: base, Cabal, uuagc-cabal - -executable uuagc - build-depends: uuagc-cabal >= 1.0.2.0 - build-depends: base >= 4, base < 5 - -- Self dependency, depend on library below - build-depends: uuagc - default-language: Haskell2010 - main-is: Main.hs - hs-source-dirs: src-main - -library - build-depends: uuagc-cabal >= 1.0.2.0 - build-depends: base >= 4, base < 5, ghc-prim >= 0.2.0.0 - if flag(with-loag) - build-depends: minisat - cpp-options: -DWITH_LOAG - build-depends: containers >= 0.3, directory >= 1.0.1.1, array >= 0.3.0.1 - build-depends: uulib >= 0.9.14, mtl >= 1.1.1.1 - build-depends: haskell-src-exts >= 1.11.1 - build-depends: filepath >= 1.1.0.4 - hs-source-dirs: src, src-version, src-ag, src-options - if !flag(bootstrap_external) - hs-source-dirs: src-generated - exposed-modules: UU.UUAGC, UU.UUAGC.Version - default-extensions: TypeSynonymInstances, MultiParamTypeClasses - default-language: Haskell2010 - other-modules: Paths_uuagc - , Ag - , CommonTypes - , GrammarInfo - , HsTokenScanner - , Options - , PPUtil - , Parser - , Pretty - , Scanner - , SequentialComputation - , SequentialTypes - , TokenDef - , Version - , AbstractSyntax - , AbstractSyntaxDump - , Code - , CodeSyntax - , CodeSyntaxDump - , ConcreteSyntax - , DeclBlocks - , DefaultRules - , Desugar - , ErrorMessages - , Expression - , GenerateCode - , HsToken - , Interfaces - , InterfacesRules - , Order - , Patterns - , PrintCode - , PrintOcamlCode - , PrintCleanCode - , PrintVisitCode - , PrintErrorMessages - , SemHsTokens - , Transform - , ATermWrite - , ATermAbstractSyntax - , TfmToVisage - , Visage - , VisageSyntax - , VisagePatterns - , AG2AspectAG - , Macro - , RhsCheck - , ResolveLocals - , Knuth1 - , KennedyWarren - , KWOrder - , ExecutionPlan - , ExecutionPlan2Hs - , ExecutionPlan2Clean - , ExecutionPlan2Caml - , LOAG.AOAG - , LOAG.Chordal - , LOAG.Common - , LOAG.Graphs - , LOAG.Order - , LOAG.Rep - if flag(with-loag) - other-modules: LOAG.Solver.MiniSat, LOAG.Optimise +cabal-version: >= 1.10 +build-type: Custom +name: uuagc +version: 0.9.54 +license: BSD3 +license-file: LICENSE +maintainer: Jeroen Bransen +homepage: http://www.cs.uu.nl/wiki/HUT/WebHome +description: Generates Haskell files from an attribute grammar specification +synopsis: Attribute Grammar System of Universiteit Utrecht +category: Development +stability: Stable +copyright: Universiteit Utrecht +author: Software Technology at Universiteit Utrecht +bug-reports: hut-developers@cs.uu.nl +tested-with: GHC >= 6.12 +extra-source-files: README +extra-source-files: uuagc_options +extra-source-files: src-ag/*.ag +extra-source-files: src-ag/LOAG/*.ag + +-- This flag will be set by Setup.hs, use +-- cabal configure --ghc-options="-DEXTERNAL_UUAGC" +flag bootstrap_external + description: Use an external uuagc executable for bootstrapping + default: False + manual: True + +flag with-loag + description: Use MiniSat as external SAT-solver to schedule all Linear Ordered AGs + default: False + manual: True + +custom-setup + setup-depends: base >= 4 && < 5, Cabal >= 1.24 && < 3.11, uuagc-cabal >= 1.0 + +executable uuagc + build-depends: uuagc-cabal >= 1.0.3.0 + build-depends: base >= 4, base < 5 + -- Self dependency, depend on library below + build-depends: uuagc + default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: src-main + +library + build-depends: uuagc-cabal >= 1.0.3.0 + build-depends: base >= 4, base < 5, ghc-prim >= 0.2.0.0 + if flag(with-loag) + build-depends: minisat + cpp-options: -DWITH_LOAG + build-depends: containers >= 0.3, directory >= 1.0.1.1, array >= 0.3.0.1 + build-depends: uulib >= 0.9.14, mtl >= 1.1.1.1 + build-depends: haskell-src-exts >= 1.11.1 + build-depends: filepath >= 1.1.0.4 + build-depends: aeson >= 1.4.7.1, bytestring >= 0.9.2.1 + hs-source-dirs: src, src-version, src-ag, src-options + if !flag(bootstrap_external) + hs-source-dirs: src-generated + exposed-modules: UU.UUAGC, UU.UUAGC.Version + default-extensions: TypeSynonymInstances, MultiParamTypeClasses + default-language: Haskell2010 + other-modules: Paths_uuagc + , Ag + , CommonTypes + , GrammarInfo + , HsTokenScanner + , Options + , PPUtil + , Parser + , Pretty + , Scanner + , SequentialComputation + , SequentialTypes + , TokenDef + , Version + , AbstractSyntax + , AbstractSyntaxDump + , Code + , CodeSyntax + , CodeSyntaxDump + , ConcreteSyntax + , DeclBlocks + , DefaultRules + , Desugar + , ErrorMessages + , Expression + , GenerateCode + , HsToken + , Interfaces + , InterfacesRules + , Order + , Patterns + , PrintCode + , PrintOcamlCode + , PrintCleanCode + , PrintVisitCode + , PrintErrorMessages + , SemHsTokens + , Transform + , ATermWrite + , ATermAbstractSyntax + , TfmToVisage + , Visage + , VisageSyntax + , VisagePatterns + , MirageSyntax + , TfmToMirage + , AG2AspectAG + , Macro + , RhsCheck + , ResolveLocals + , Knuth1 + , KennedyWarren + , KWOrder + , ExecutionPlan + , ExecutionPlan2Hs + , ExecutionPlan2Clean + , ExecutionPlan2Caml + , LOAG.AOAG + , LOAG.Chordal + , LOAG.Common + , LOAG.Graphs + , LOAG.Order + , LOAG.Rep + if flag(with-loag) + other-modules: LOAG.Solver.MiniSat, LOAG.Optimise diff --git a/uuagc_options b/uuagc_options --- a/uuagc_options +++ b/uuagc_options @@ -1,117 +1,120 @@ -file: "src-ag/AbstractSyntax.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/ConcreteSyntax.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/ErrorMessages.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/HsToken.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/Code.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/Expression.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/Patterns.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/Interfaces.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/CodeSyntax.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/DeclBlocks.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/VisageSyntax.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/VisagePatterns.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/ExecutionPlan.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - -file: "src-ag/LOAG/Order.ag" -options: module, pretty, checkParseHaskell, self, wrappers, signatures, catas, semfuns, genlinepragmas, kennedywarren - -file: "src-ag/LOAG/Prepare.ag" -options: module, pretty, checkParseHaskell, self, wrappers, signatures, catas, semfuns, genlinepragmas, kennedywarren - -file: "src-ag/LOAG/Rep.ag" -options: module, pretty, checkParseHaskell, self, datarecords, data, optimize - -file: "src-ag/Macro.ag" -options: module, pretty, data, genlinepragmas, checkParseHaskell - - -file: "src-ag/Desugar.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren, visit - -file: "src-ag/DefaultRules.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren, visit - -file: "src-ag/GenerateCode.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/PrintCleanCode.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/PrintOcamlCode.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/PrintCode.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/PrintVisitCode.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/PrintErrorMessages.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/SemHsTokens.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/Transform.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/Order.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/KWOrder.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/ResolveLocals.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/AbstractSyntaxDump.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/CodeSyntaxDump.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/Visage.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/TfmToVisage.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/AG2AspectAG.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/ExecutionPlan2Hs.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/ExecutionPlan2Clean.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/ExecutionPlan2Caml.ag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren - -file: "src-ag/InterfacesRules.lag" -options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren +file: "src-ag/AbstractSyntax.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/ConcreteSyntax.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/ErrorMessages.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/HsToken.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/Code.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/Expression.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/Patterns.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/Interfaces.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/CodeSyntax.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/DeclBlocks.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/VisageSyntax.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/VisagePatterns.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/ExecutionPlan.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + +file: "src-ag/LOAG/Order.ag" +options: module, pretty, checkParseHaskell, self, wrappers, signatures, catas, semfuns, genlinepragmas, kennedywarren + +file: "src-ag/LOAG/Prepare.ag" +options: module, pretty, checkParseHaskell, self, wrappers, signatures, catas, semfuns, genlinepragmas, kennedywarren + +file: "src-ag/LOAG/Rep.ag" +options: module, pretty, checkParseHaskell, self, datarecords, data, optimize + +file: "src-ag/Macro.ag" +options: module, pretty, data, genlinepragmas, checkParseHaskell + + +file: "src-ag/Desugar.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren, visit + +file: "src-ag/DefaultRules.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren, visit + +file: "src-ag/GenerateCode.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/PrintCleanCode.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/PrintOcamlCode.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/PrintCode.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/PrintVisitCode.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/PrintErrorMessages.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/SemHsTokens.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/Transform.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/Order.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/KWOrder.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/ResolveLocals.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/AbstractSyntaxDump.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/CodeSyntaxDump.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/Visage.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/TfmToVisage.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/TfmToMirage.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/AG2AspectAG.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/ExecutionPlan2Hs.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/ExecutionPlan2Clean.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/ExecutionPlan2Caml.ag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren + +file: "src-ag/InterfacesRules.lag" +options: module, pretty, newtypes, wrappers, catas, semfuns, signatures, genlinepragmas, checkParseHaskell, kennedywarren