diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,41 @@ +The Utrecht Haskell Compiler (UHC) License +========================================== + +UHC follows the advertisement free BSD license, of which the basic +template can be found here: + + http://www.opensource.org/licenses/bsd-license.php + +UHC uses the following libraries with their own license: +- Library code from the GHC distribution, see comment in the modules in ehclib + +License text +============ + +Copyright (c) 2009-2010, Utrecht University, Department of Information +and Computing Sciences, Software Technology group + +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. + +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 THE COPYRIGHT +HOLDER OR CONTRIBUTORS 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +import Distribution.Simple (defaultMainWithHooks) +import Distribution.Simple.Shuffle (shuffleHooks) +import Distribution.Simple.UUAGC (uuagcLibUserHook) +import UU.UUAGC (uuagc) + +main :: IO () +main = defaultMainWithHooks $ shuffleHooks $ uuagcLibUserHook uuagc diff --git a/demo/Makefile b/demo/Makefile new file mode 100644 --- /dev/null +++ b/demo/Makefile @@ -0,0 +1,65 @@ +## Tools used +SHUFFLE := shuffle +RULER := ruler +AGC := uuagc +GHC := ghc +GHC_OPTS := -XTypeSynonymInstances -XFlexibleInstances -XFlexibleContexts + +## General settings +BUILD_PREFIX := build/ +RULER_DEMO_EXEC := rulerdemo + +## Shuffle settings +SHUFFLE_ORDER := 1 < 2 < 3 +SHUFFLE_FINAL := 3 +SHUFFLE_OPTS := --markchanges="E - AG" + +## File names +AG_MAIN := RulerDemoMain +SRC_CAG_MAIN := $(AG_MAIN).cag +DRV_AG_MAIN := $(BUILD_PREFIX)$(AG_MAIN).ag +DRV_HS_MAIN := $(BUILD_PREFIX)$(AG_MAIN).hs +RUL_BASE := rulerDemoRL +SRC_CRL := $(RUL_BASE).crl2 +DRV_RL2 := $(BUILD_PREFIX)$(RUL_BASE).rl2 +AG_BASE := rulerDemoAG +DRV_CAG := $(BUILD_PREFIX)demo.cag +DRV_AG := $(BUILD_PREFIX)demo.ag +UTILS := RulerDemoUtils +SRC_CHS_UTILS := $(UTILS).chs +DRV_HS_UTILS := $(BUILD_PREFIX)$(UTILS).hs + +## Actual rules +all: $(RULER_DEMO_EXEC) + +$(DRV_AG_MAIN): $(SRC_CAG_MAIN) + @mkdir -p $(@D) + $(SHUFFLE) --gen-reqm=$(SHUFFLE_FINAL) --ag --variant-order="$(SHUFFLE_ORDER)" --base=Main --preamble=no --lhs2tex=no $< > $@ + +$(DRV_RL2): $(SRC_CRL) + @mkdir -p $(@D) + $(SHUFFLE) --gen-reqm=$(SHUFFLE_FINAL) --plain --variant-order="$(SHUFFLE_ORDER)" --lhs2tex=no $< > $@ + +$(DRV_CAG): $(DRV_RL2) + @mkdir -p $(@D) + $(RULER) $(RULER2_OPTS) --ag --ATTR --DATA --selrule="(3).(*).(*)" --wrapshuffle --base=$(AG_BASE) $< > $@ + +$(DRV_AG): $(DRV_CAG) + @mkdir -p $(@D) + $(SHUFFLE) --gen-reqm=$(SHUFFLE_FINAL) --plain --variant-order="$(SHUFFLE_ORDER)" --lhs2tex=no $< > $@ + +$(DRV_HS_MAIN): $(DRV_AG_MAIN) $(DRV_AG) + @mkdir -p $(@D) + $(AGC) -csdfr -P$(BUILD_PREFIX) $< + +$(DRV_HS_UTILS): $(SRC_CHS_UTILS) + @mkdir -p $(@D) + $(SHUFFLE) --gen-reqm=$(SHUFFLE_FINAL) --hs --variant-order="$(SHUFFLE_ORDER)" --preamble=no --lhs2tex=no $< > $@ + +$(RULER_DEMO_EXEC): $(DRV_HS_MAIN) $(DRV_HS_UTILS) + @mkdir -p $(@D) + $(GHC) --make $(GHC_OPTS) -i$(BUILD_PREFIX) $(DRV_HS_MAIN) -o $@ + +# Cleaning up +clean: + @rm -rf $(BUILD_PREFIX) diff --git a/demo/RulerDemoMain.cag b/demo/RulerDemoMain.cag new file mode 100644 --- /dev/null +++ b/demo/RulerDemoMain.cag @@ -0,0 +1,129 @@ +%%[0 +%include lhs2TeX.fmt +%include afp.fmt +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Haskell interface to AG generated code for compiler +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 hs import(System.IO,Data.List,UU.Pretty,UU.Parsing,UU.Scanner,UU.Scanner.Position( initPos, Pos ),RulerDemoUtils) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Import of generated part (type rule implementation) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 import(demo) +WRAPPER AGItf +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Main +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 hs +-- main +main :: IO () +main + = do { txt <- hGetContents stdin + ; let tokens = scan ["let", "in"] ["->", "=", "\\"] + "()" "\\->=" (initPos "") txt + ; pres <- parseIOMessage show pAGItf tokens + ; let res = wrap_AGItf pres Inh_AGItf + ; putStrLn (disp (pp_Syn_AGItf res) 200 "") + } + +-- Parser +pAGItf :: (IsParser p Token) => p T_AGItf +pAGItf + = pAGItf + where pAGItf = sem_AGItf_AGItf <$> pExpr + pExprBase = pParens pExpr + <|> sem_Expr_Var <$> pVarid + <|> (sem_Expr_Int . read) <$> pInteger + pExprApp = foldl1 sem_Expr_App <$> pList1 pExprBase + pExprPre = sem_Expr_Let + <$ pKey "let" <*> pVarid + <* pKey "=" <*> pExpr <* pKey "in" + <|> sem_Expr_Lam + <$ pKey "\\" <*> pVarid + <* pKey "->" + pExpr = pExprPre <*> pExpr + <|> pExprApp +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% AST +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 +-- AST +DATA AGItf + | AGItf e : Expr +%%] + +%%[33.AST.Expr.App +DATA Expr + | App f : Expr + a : Expr +%%] +%%[33.AST.Expr.IntVar + | Int int : {Int} + | Var i : {String} +%%] +%%[33.AST.Expr.Rest + | Lam i : {String} + b : Expr + | Let i : {String} + e : Expr + b : Expr +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Initialisation +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 +-- Initialisation +SEM AGItf + | AGItf e . g = [] + . c = [] +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Pretty printing +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 +-- Pretty printing +ATTR AGItf Expr [ | | pp: PP_Doc ] + +SEM Expr + | App lhs . pp = @f.pp >#< pp_parens @a.pp + >-< mkErr @mtErrs + | Int lhs . pp = pp @int + | Var lhs . pp = pp @i >-< mkErr @nmErrs + | Lam lhs . pp = "\\" >|< pp @i >#< "->" >#< @b.pp + | Let lhs . pp = "let" >#< pp @i + >#< "::" >#< show @pty_e_ + >#< "=" >#< @e.pp + >-< "in " >#< @b.pp +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Uniq +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 +-- Uniq +%%] + +%%[3.uniq +ATTR Expr [ | uniq: UID | ] + +SEM AGItf + | AGItf e . uniq = uidStart +%%] + + diff --git a/demo/RulerDemoUtils.chs b/demo/RulerDemoUtils.chs new file mode 100644 --- /dev/null +++ b/demo/RulerDemoUtils.chs @@ -0,0 +1,165 @@ +%%[0 +%include lhs2TeX.fmt +%include afp.fmt +%%] + +%%[3 module RulerDemoUtils import(Data.List,UU.Pretty) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Error +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 +-- Error +mkErr :: [PP_Doc] -> PP_Doc +mkErr [] = empty +mkErr p = "#< vlist p >|< ">" +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Unique identifier +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 +-- Unique identifier +%%] + +%%[3.UID +newtype UID = UID [Int] deriving (Eq,Ord) +uidStart = UID [0] + +rulerMk1Uniq :: UID -> (UID,UID) +rulerMk1Uniq u@(UID ls) = (uidNext u,UID (0:ls)) + +uidNext :: UID -> UID +uidNext (UID (l:ls)) = UID (l+1:ls) +%%] + +%%[3 +mkUIDs :: UID -> [UID] +mkUIDs = iterate uidNext + +instance Show UID where + show (UID l) + = concat . intersperse "_" . map show . reverse $ l +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Type +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 +-- Type +%%] + +%%[3.Ty +type TvId = UID +data Ty = Ty_Any | Ty_Int | Ty_Var TvId + | Ty_Arr Ty Ty + | Ty_All [TvId] Ty + deriving (Eq,Ord) +%%] + +%%[3 +mkTyAll tvs t = if null tvs then t else Ty_All tvs t + +instance Show Ty where + show Ty_Any = "?" + show Ty_Int = "Int" + show (Ty_Var v) = "v" ++ show v + show (Ty_All vs t) = "forall" ++ concat (map ((' ':) . show) vs) + ++ " . " ++ show t + show (Ty_Arr t1 t2) = "(" ++ show t1 ++ ") -> " ++ show t2 +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Gam +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 +-- Gam +type Gam = [(String,Ty)] + +gamLookup :: String -> Gam -> (Ty,[PP_Doc]) +gamLookup n g + = maybe (Ty_Any,[n >#< "undefined"]) (\t -> (t,[])) + $ lookup n g +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Constraints +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 +-- Constraints +%%] + +%%[3.Cnstr +type Cnstr = [(TvId,Ty)] + +class Substitutable a where + (|=>) :: Cnstr -> a -> a + ftv :: a -> [TvId] + +instance Substitutable Ty where + s |=> t@(Ty_Var v) = maybe t id (lookup v s) + s |=> Ty_Arr t1 t2 = Ty_Arr (s |=> t1) (s |=> t2) + _ |=> t = t + ftv (Ty_Var v) = [v] + ftv (Ty_Arr t1 t2) = ftv t1 `union` ftv t2 + ftv _ = [] +%%] + +%%[3 +instance Substitutable Cnstr where + s1 |=> s2 = s1 ++ map (\(v,t) -> (v,s1 |=> t)) s2 + ftv = foldr union [] . map (ftv . snd) + +instance Substitutable Gam where + s |=> g = map (\(i,t) -> (i,s |=> t)) g + ftv = foldr union [] . map (ftv . snd) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Type matching (unification) +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +-- Type matching (unification) +%%[3.match.A +(<=>) :: Ty -> Ty -> (Cnstr,[PP_Doc]) +Ty_Any <=> t2 = ([],[]) +t1 <=> Ty_Any = ([],[]) +Ty_Int <=> Ty_Int = ([],[]) +Ty_Var v1 <=> Ty_Var v2 + | v1 == v2 = ([],[]) +Ty_Var v1 <=> t2 + | v1 `notElem` ftv t2 = ([(v1,t2)],[]) +%%] + +%%[3.match.B +t1 <=> Ty_Var v2 + | v2 `notElem` ftv t1 = ([(v2,t1)],[]) +Ty_Arr a1 r1 <=> Ty_Arr a2 r2 + = (sr |=> sa,ea ++ er) + where (sa,ea) = a1 <=> a2 + (sr,er) = (sa |=> r1) <=> (sa |=> r2) +t1 <=> t2 = ([],["could not match" + >#< show t1 >#< "with" + >#< show t2] + ) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Type instantiation +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3 +-- Type instantiation +tyInst :: UID -> Ty -> Ty +tyInst u (Ty_All vs t) = c |=> t + where c = zipWith (\v u -> (v,Ty_Var u)) + vs (mkUIDs u) +tyInst _ t = t +%%] + diff --git a/demo/rulerDemoRL.crl2 b/demo/rulerDemoRL.crl2 new file mode 100644 --- /dev/null +++ b/demo/rulerDemoRL.crl2 @@ -0,0 +1,361 @@ +%%[0 +%include lhs2TeX.fmt +%include afp.fmt +%include ruler.fmt +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Preambles +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[1 +preamble tex "%include lhs2TeX.fmt\n%include afp.fmt\n" +%%] + +%%[3 +preamble ag "%%[0\n%include lhs2TeX.fmt\n%include afp.fmt\n%%]\n" +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Externally defined +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[1.ext +external Ty_Int +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Data def +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3.data +data Expr [expr] + view E + | App [e.app] f :: Expr + a :: Expr + | Int [e.int] int :: Int + | Var [e.var] i :: String + | Lam [e.lam] i :: String + b :: Expr + | Let [e.let] i :: String + e :: Expr + b :: Expr +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Formatting +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[1.fmt.Ty_Int +format tex Ty_Int = Int +%%] + +%%[1.fmt +format tex Gam = Gamma +format tex gam = Gamma + +format tex ty = tau +format tex pty = sigma +format tex mty = tau +%%] + +%%[2.fmt +format tex tv = v + +format tex cnstr.inh = Cnstr..k +format tex cnstr.syn = Cnstr +format tex cnstr = Cnstr +%%] + +%%[3.fmt +format ag cnstr = c +format ag gam = g +%%] +format ag ty = t + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Rewriting +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[3.rw.TyArr +rewrite ag def (a | Ty) -> (r | Ty) = ((a) `Ty_Arr` (r) | Ty) +%%] + +%%[3.rw.Cnstr +rewrite ag def (c1 | Cnstr) (c2 | Cnstr) (v | a) + = (c1 |=> c2 |=> (v) | a) +%%] + +%%[3.rw.Rest +rewrite ag def (c | Cnstr) (v | a) = (c |=> (v) | a) +rewrite ag def i :-> t = ([(i,t)] | Gam) +rewrite ag def (g1 | Gam), (g2 | Gam) = ((g1) ++ (g2) | Gam) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% View hierarchy +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[1.viewhierarchy +viewhierarchy = E < A < AG +%%] + +%%[3.viewhierarchy -1.viewhierarchy +viewhierarchy = E < A < AG < 3 +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Expr scheme +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[1.expr.scm +scheme expr = +%%] +%%[3.expr.scm -1.expr.scm +scheme expr "Expr" = +%%] +%%[1.expr.scm.E + view E = + holes [ e: Expr, gam: Gam, ty: Ty ] + judgespec gam :- e : ty + judgeuse tex gam :-.."e" e : ty +%%] + +%%[2.expr.scm.A + view A = + holes [ inh gam: Gam, thread cnstr: Cnstr, syn ty: Ty ] + judgespec cnstr.inh ; gam :- e : ty ~> cnstr.syn + judgeuse tex cnstr.inh ; gam :-.."e" e : ty ~> cnstr.syn +%%] + +%%[3.expr.scm.AG + view AG = + holes [ node e: Expr | | ] +%%] + judgespec cnstr.inh ; gam :-.."e" e : ty ~> cnstr.syn + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Expr rules +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[1.expr.base.rls +ruleset expr.base scheme expr "Expression type rules" = +%%] +%%[1.rl.e.int + rule e.int = +%%] +%%[3.rl.e.int -1.rl.e.int + rule e.int "Int" = +%%] +%%[1.rl.e.int.E + view E = -- no premises + - + judge R : expr = gam :- int : Ty_Int +%%] +%%[2.rl.e.int.A + view A = + - + judge R : expr + | cnstr.syn = cnstr..k + | cnstr.inh = cnstr..k +%%] + +%%[1.rl.e.var + rule e.var = +%%] +%%[3.rl.e.var -1.rl.e.var + rule e.var "Var" = +%%] +%%[1.rl.e.var.E + view E = + judge G : gamLookupIdTy = i :-> pty `elem` gam + judge I : tyInst = ty `=` inst(pty) + - + judge R : expr = gam :- i : ty +%%] +%%[2.rl.e.var.A + view A = + - + judge R : expr + | cnstr.syn = cnstr.inh +%%] + +%%[1.rl.e.app + rule e.app = +%%] +%%[3.rl.e.app -1.rl.e.app + rule e.app "App" = +%%] +%%[1.rl.e.app.E + view E = + judge A : expr = gam :- a : ty.a + judge F : expr = gam :- f : (ty.a -> ty) + - + judge R : expr = gam :- (f a) : ty +%%] +%%[2.rl.e.app.A + view A = + judge V : tvFresh = tv + judge M : match = (ty.a -> tv) <=> (cnstr.a ty.f) + ~> cnstr + judge F : expr + | ty = ty.f + | cnstr.syn = cnstr.f + judge A : expr + | cnstr.inh = cnstr.f + | cnstr.syn = cnstr.a + - + judge R : expr + | ty = cnstr cnstr.a tv + | cnstr.syn = cnstr cnstr.a +%%] +%%[33.rl.e.app.AG + view AG = + - + judge R : expr + | e = ((node 1 = f) (node 2 = a)) +%%] + +%%[1.rl.e.lam + rule e.lam = +%%] +%%[3.rl.e.lam -1.rl.e.lam + rule e.lam "Lam" = +%%] +%%[1 + view E = + judge B : expr = ((i :-> ty.i) , gam) :- b : ty.b + - + judge R : expr = gam :- (\i -> b) : (ty.i -> ty.b) +%%] +%%[2 + view A = + judge V : tvFresh = tv + judge B : expr + | cnstr.syn = cnstr.b + | gam = (i :-> tv) , gam + - + judge R : expr + | ty = cnstr.b tv -> ty.b + | cnstr.syn = cnstr.b +%%] +%%[33 + view AG = + - + judge R : expr + | e = \i -> (node 1 = b) +%%] + +%%[1.rl.e.let + rule e.let = +%%] +%%[3.rl.e.let -1.rl.e.let + rule e.let "Let" = +%%] +%%[1 + view E = + judge D : expr = gam :- e : ty.e + judge B : expr = ((i :-> pty.e), gam) :- b : ty.b + judge G : tyGen = pty.e `=` ty.e \\ gam + - + judge R : expr = gam :- (let i `=` e in b) : ty.b +%%] +%%[2 + view A = + judge V : tvFresh = tv + judge D : expr + | cnstr.syn = cnstr.e + | gam = (i :-> tv) , gam + judge B : expr + | cnstr.inh = cnstr.e + | cnstr.syn = cnstr.b + judge G : tyGen + | gam = cnstr.e gam + - + judge R : expr + | cnstr.syn = cnstr.b +%%] +%%[33 + view AG = + - + judge R : expr + | e = let i `=` (node 1 = e) in (node 2 = b) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Match two types +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[2.match +relation match = + view A = + holes [ ty.l: Ty, ty.r: Ty | | cnstr: Cnstr ] + judgespec ty.l <=> ty.r ~> cnstr + judgeuse ag (cnstr,mtErrs) `=` (ty.l) <=> (ty.r) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Lookup ty in gam +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[1.gamLookupIdTy +relation gamLookupIdTy = + view E = + holes [ nm: Nm, gam: Gam, ty: Ty ] + judgespec nm :-> ty `elem` gam +%%] +%%[3.gamLookupIdTy + view AG = + holes [ nm: Nm, gam: Gam | | ty: Ty ] + judgeuse ag (ty,nmErrs) `=` gamLookup nm gam +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Fresh type variables +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[2.tvFresh +relation tvFresh = + view A = + holes [ | | tv: Ty ] + judgespec tv + judgeuse tex tv (text "fresh") + judgeuse ag tv `=` Ty_Var unique +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Type instantiation +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[1.tyInst +relation tyInst = + view E = + holes [ | ty: Ty, ty.i: Ty | ] + judgespec ty.i `=` inst(ty) +%%] +%%[3.tyInst + view AG = + holes [ ty: Ty | | ty.i: Ty ] + judgeuse ag ty.i `=` tyInst unique (ty) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Type generalisation +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[1.tyGen +relation tyGen = + view E = + holes [ ty: Ty, gam: Gam | | pty: Ty ] + judgespec pty `=` ty \\ gam + judgeuse tex pty `=` forall v..._ `.` ty, ^^^ v..._ `notElem` ftv(gam) +%%] +%%[2.tyGen + view A = + judgeuse tex pty `=` forall (ftv(ty) \\ ftv(gam)) `.` ty +%%] +%%[3.tyGen + view AG = + judgeuse ag (retain pty) `=` mkTyAll (ftv(ty) \\ ftv(gam)) (ty) +%%] + diff --git a/demo/tst1 b/demo/tst1 new file mode 100644 --- /dev/null +++ b/demo/tst1 @@ -0,0 +1,2 @@ +let i = 5 +in i diff --git a/demo/tst2 b/demo/tst2 new file mode 100644 --- /dev/null +++ b/demo/tst2 @@ -0,0 +1,7 @@ +let id = \x -> x +in +let v1 = id 3 +in +let v2 = id id +in v1 + diff --git a/demo/tst3 b/demo/tst3 new file mode 100644 --- /dev/null +++ b/demo/tst3 @@ -0,0 +1,4 @@ +let app = \f -> \a -> f a +in +let v = app 3 j +in v diff --git a/demo/tst5 b/demo/tst5 new file mode 100644 --- /dev/null +++ b/demo/tst5 @@ -0,0 +1,4 @@ +let id = \x -> x +in let v1 = id 3 + in let v2 = id id + in v2 v1 diff --git a/ruler.cabal b/ruler.cabal new file mode 100644 --- /dev/null +++ b/ruler.cabal @@ -0,0 +1,72 @@ +Name: ruler +Version: 0.4.0.0 +Copyright: Utrecht University, Department of Information and Computing Sciences, Software Technology group +Description: Ruler tool used by UHC (Utrecht Haskell Compiler) +Synopsis: Ruler tool for UHC +Homepage: https://github.com/UU-ComputerScience/ruler +Bug-Reports: https://github.com/UU-ComputerScience/ruler/issues +License: BSD3 +License-file: LICENSE +Author: UHC Team +Maintainer: uhc-developers@lists.science.uu.nl +Category: Development +Build-Type: Custom +Cabal-Version: >= 1.8 +Extra-Source-Files: demo/RulerDemoUtils.chs + demo/RulerDemoMain.cag + demo/rulerDemoRL.crl2 + demo/Makefile + demo/tst1 + demo/tst2 + demo/tst3 + demo/tst5 + +Source-Repository head + Type: git + Location: https://github.com/UU-ComputerScience/ruler.git + + +executable ruler + main-is: Ruler.hs + hs-source-dirs: src + extensions: FlexibleContexts, TypeSynonymInstances, FlexibleInstances, RankNTypes, MultiParamTypeClasses + x-shuffle-hs: --gen-reqm=1 --preamble=no --lhs2tex=no --variant-order="1" + x-shuffle-ag: --gen-reqm=1 --preamble=no --lhs2tex=no --variant-order="1" + x-shuffle-ag-d: data, rename + x-shuffle-ag-s: catas, semfuns, signatures, pretty, rename + x-shuffle-ag-sd: data, catas, semfuns, signatures, pretty, rename, module + x-shuffle-ag-d-dep: Expr/Expr.cag + Ty/Ty.cag + AbsSyn/AbsSyn1.cag + AbsSyn/AbsSyn2.cag + ViewSel/ViewSel.cag + ARule/ARule.cag + x-shuffle-ag-s-dep: Main1AG.cag + AS1/Imports.cag + Main2AG.cag + TrfAS2/GenARule.cag + TrfAS2/GenLaTeX.cag + Ty/PrettyPrint.cag + Expr/IsRw.cag + Expr/NmS.cag + Expr/LaTeX.cag + Expr/CoGam.cag + ViewSel/Self.cag + ViewSel/NmS.cag + ViewSel/RlRnm.cag + ViewSel/RlIsSel.cag + ViewSel/PrettyPrint.cag + ARule/PatternUniq.cag + ARule/RwSubst.cag + ARule/AVarRename.cag + ARule/ElimCopyRule.cag + ARule/ElimWildcAssign.cag + ARule/PrettyPrint.cag + build-depends: base >= 4 && < 5, + containers >= 0.4 && < 0.6, + uulib >= 0.9 && < 1, + mtl >= 2 && < 3, + uhc-util >= 0.1.0.2, + uuagc >= 0.9.42.2, + uuagc-cabal >= 1.0.4.0, + shuffle >= 0.1.0.2 diff --git a/src/ARule/ARule.cag b/src/ARule/ARule.cag new file mode 100644 --- /dev/null +++ b/src/ARule/ARule.cag @@ -0,0 +1,16 @@ +------------------------------------------------------------------------- +-- Haskell interface to ARule AST +------------------------------------------------------------------------- + +%%[1 hs module (ARule.ARule) +%%] + +%%[1 hs import(Common, Expr.Expr) +%%] + +%%[1 ag import({ARule/AbsSynAG}) +%%] + +%%[1 hs + +%%] diff --git a/src/ARule/AVarRename.cag b/src/ARule/AVarRename.cag new file mode 100644 --- /dev/null +++ b/src/ARule/AVarRename.cag @@ -0,0 +1,109 @@ +------------------------------------------------------------------------- +-- Optimisation: ARule/Expr rename of AVar +------------------------------------------------------------------------- + +%%[1 hs module (ARule.AVarRename) +%%] + +%%[1 hs export (arlElimAlphaRename) +%%] + +%%[1 hs import (qualified Data.Map as Map, Common, Expr.Expr, ARule.ARule, FmGam) +%%] + +%%[1 ag import({Expr/AbsSynAG}, {ARule/AbsSynAG}, {Expr/SelfAG}, {ARule/SelfAG}) +%%] + +%%[1 ag import({ARule/EqnDest1NmAG}, {ARule/InCompDestAG}) +%%] + +%%[1 ag +WRAPPER AGExprItf AGARuleItf +%%] + +%%[1 hs +exprASubst :: RnMp -> Expr -> Expr +exprASubst rnm e + = self_Syn_AGExprItf r2 + where r1 = sem_AGExprItf (AGExprItf_AGItf e) + r2 = wrap_AGExprItf r1 + (Inh_AGExprItf { rnMp_Inh_AGExprItf = rnm + }) + +arlElimAlphaRename :: ARule -> ARule +arlElimAlphaRename r + = self_Syn_AGARuleItf r2 + where r1 = sem_AGARuleItf (AGARuleItf_AGItf r) + r2 = wrap_AGARuleItf r1 + (Inh_AGARuleItf) +%%] + + +------------------------------------------------------------------------- +-- Part I: Elimination of alpha renaming +------------------------------------------------------------------------- + +------------------------------------------------------------------------- +-- Rename map gather +------------------------------------------------------------------------- + +%%[1 hs +rnRepl :: RnMp -> RnSrc -> RnSrc +rnRepl m e + = case e of + RnExpr (Expr_AVar (ANm_Loc n _)) -> r n + RnNm (ANm_Loc n _) -> r n + _ -> e + where r n = maybe e (RnExpr . exprASubst (Map.delete n m) . rnSrc2Expr . snd) (Map.lookup n m) +%%] + +%%[1 ag +ATTR AEqns AEqn ANm AllExpr AExpr [ | | gathRnMp USE {`rnMpUnion`} {Map.empty}: RnMp ] +ATTR AllARuleButARule AllExpr AGExprItf [ rnMp: RnMp | | ] + +SEM AEqn + | Eqn loc . gathRnMp = let m = case @dest.mbSingleANm of + Just (ANm_Loc dn p) | AtRetain `notElem` p + -> Map.singleton dn (0,v) + where v = case (@val.mbSingleANm,@val.self) of + (Just sn,_ ) -> RnNm sn + (_ ,AExpr_Expr e) -> RnExpr e + _ -> Map.empty + in m `rnMpUnion` @val.gathRnMp + +SEM ANm + | Loc lhs . gathRnMp = Map.singleton @nm (1,RnNone) + +SEM ARule + | Rule eqns . rnMp = Map.filter (\(c,v) + -> case v of + RnNone -> False + RnExpr _ | c > 1 -> False + _ -> True + ) + @eqns.gathRnMp +%%] + +------------------------------------------------------------------------- +-- Replica +------------------------------------------------------------------------- + +%%[1 ag +ATTR AEqns AEqn [ | | replRnEqns USE {++} {[]}: {[AEqn]} ] + +SEM Expr + | AVar lhs . self = rnSrc2Expr (rnRepl @lhs.rnMp (RnExpr @self)) + +SEM AEqn + | Eqn lhs . replRnEqns = case @dest.mbSingleANm of + Just (ANm_Loc n _) + -> case Map.lookup n @lhs.rnMp of + Just _ -> [] + _ -> [@self] + _ -> [@self] + | * - Eqn lhs . replRnEqns = [@self] + +SEM ARule + | Rule lhs . self = ARule_Rule @ndNmL @rlNm @info @eqns.replRnEqns + +%%] diff --git a/src/ARule/AbsSynAG.cag b/src/ARule/AbsSynAG.cag new file mode 100644 --- /dev/null +++ b/src/ARule/AbsSynAG.cag @@ -0,0 +1,46 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- Interfacing +------------------------------------------------------------------------- + +DATA AGARuleItf + | AGItf rule : ARule + +------------------------------------------------------------------------- +-- Rule in AG form +------------------------------------------------------------------------- + +DATA ARule + | Rule ndNmL : {[Nm]} + rlNm : {Nm} + info : {[String]} + eqns : AEqns + +TYPE ARules = [ARule] + +DATA AEqn + | Eqn dest : AEqnDest + val : AExpr + | Err expr : Expr + +TYPE AEqns = [AEqn] + +DATA AExpr + | Expr expr : Expr + +DATA AEqnDest + | One anm : ANm + | Many dests : AEqnDests + +TYPE AEqnDests = [AEqnDest] + +SET AllARuleEqn = AEqn AEqns + +SET AllARuleRule = ARule ARules + +SET AllARuleButARule = AllARuleEqn AExpr AEqnDest AEqnDests + +SET AllARule = AllARuleRule AllARuleButARule + +%%] diff --git a/src/ARule/CopyRuleNmAG.cag b/src/ARule/CopyRuleNmAG.cag new file mode 100644 --- /dev/null +++ b/src/ARule/CopyRuleNmAG.cag @@ -0,0 +1,9 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- Copy Rule nms +------------------------------------------------------------------------- + +ATTR AGARuleItf [ croNmL: {[Nm]} | | ] + +%%] diff --git a/src/ARule/ElimCopyRule.cag b/src/ARule/ElimCopyRule.cag new file mode 100644 --- /dev/null +++ b/src/ARule/ElimCopyRule.cag @@ -0,0 +1,117 @@ +------------------------------------------------------------------------- +-- Optimisation: ARule copy rule elimination +------------------------------------------------------------------------- + +%%[1 hs module (ARule.ElimCopyRule) +%%] + +%%[1 hs export (module Gam, AtDefdGam, AtDefdGam', adGamUnion, ppADGam, CrOrdGam, arlElimCopyRule) +%%] + +%%[1 hs import (qualified Data.Map as Map, qualified Data.Set as Set, UHC.Util.Pretty, Common, Expr.Expr, ARule.ARule, Gam) +%%] + +%%[1 ag import ({Expr/AbsSynAG}, {ARule/AbsSynAG}, {Expr/SelfAG}, {ARule/SelfAG}) +%%] + +%%[1 ag import ({ARule/CopyRuleNmAG}, {ARule/EqnDest1NmAG}, {ARule/InCompDestAG}) +%%] + +%%[1 ag +WRAPPER AGARuleItf +%%] + +%%[1 hs +arlElimCopyRule :: [Nm] -> AtDefdGam -> AtDefdGam' -> ARule -> ARule +arlElimCopyRule co ag ag2 rl + = self_Syn_AGARuleItf r2 + where r1 = sem_AGARuleItf (AGARuleItf_AGItf rl) + r2 = wrap_AGARuleItf r1 + (Inh_AGARuleItf {croNmL_Inh_AGARuleItf = co + ,adGam_Inh_AGARuleItf = ag + ,ad2Gam_Inh_AGARuleItf = ag2 + }) +%%] + +------------------------------------------------------------------------- +-- Copy rule order, ref to previous node +------------------------------------------------------------------------- + +%%[1 hs +type CrOrdGam = Gam Nm Nm +%%] + +------------------------------------------------------------------------- +-- Non local attr's defined, threaded? +------------------------------------------------------------------------- + +%%[1 hs +type AtDefdGam = Gam Nm Bool +type AtDefdGam' = Gam Nm (Set.Set Nm) + +adGamUnion :: AtDefdGam' -> AtDefdGam' -> AtDefdGam' +adGamUnion = gamUnionWith Set.union + +ppADGam :: AtDefdGam' -> PP_Doc +ppADGam = ppGam . gamMap (pp.show) + +adGamIsThr :: AtDefdGam -> AtDefdGam' -> CrOrdGam -> Nm -> Nm -> Nm -> Bool +adGamIsThr ag1 ag2 cg + = if gamIsEmpty ag2 then isThr1 else isThr2 + where isThr1 _ _ nAt = gamFindWithDefault False nAt ag1 + isThr2 nNd1 nNd2 nAt + = case gamLookup nNd2 cg of + Nothing -> False + Just nNd1' + | nNd1 == nNd1' + -> isComingOut + | not isComingOut + -> isThr2 nNd1 nNd1' nAt + | otherwise + -> False + where isComingOut = maybe False (nNd1' `Set.member`) $ gamLookup nAt ag2 +%%] + +------------------------------------------------------------------------- +-- Context +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllARuleRule AllARuleEqn AGARuleItf [ adGam: AtDefdGam | | ] +ATTR AllARuleRule AllARuleEqn AGARuleItf [ ad2Gam: {AtDefdGam'} | | ] +ATTR AllARuleRule AllARuleEqn [ croGam: CrOrdGam | | ] + +SEM AGARuleItf + | AGItf rule . croGam = fst . foldl (\(g,pn) n -> (gamInsert n pn g,n)) (emptyGam,head @lhs.croNmL) $ tail @lhs.croNmL +%%] + +------------------------------------------------------------------------- +-- Replica +------------------------------------------------------------------------- + +%%[1 ag +ATTR AEqns AEqn [ | | replCrEqns USE {++} {[]}: {[AEqn]} ] + +SEM AEqn + | Eqn lhs . replCrEqns = let -- isThr n = gamFindWithDefault False n @lhs.adGam + isThr = adGamIsThr @lhs.adGam @lhs.ad2Gam @lhs.croGam + isPrev1 n1 n2 = maybe False (==n1) $ gamLookup n2 @lhs.croGam + isPrev = if gamIsEmpty @lhs.ad2Gam then isPrev1 else \_ _ -> True + in case (@dest.mbSingleANm,@val.mbSingleANm) of + (Just (ANm_Node nn dn),Just (ANm_Lhs sn _)) | gamIsEmpty @lhs.ad2Gam && dn == sn && not (isThr nmLhs nn dn) + -> [] + (Just (ANm_Node nn dn),Just (ANm_Lhs sn _)) | dn == sn && (isThr nmLhs nn dn) && nmLhs `isPrev` nn + -> [] + (Just (ANm_Node nn1 dn),Just (ANm_Node nn2 sn)) | dn == sn && (isThr nn2 nn1 dn) && nn2 `isPrev` nn1 + -> [] + (Just (ANm_Lhs dn _),Just (ANm_Node nn sn)) | dn == sn {- && (isThr sn) -} && nn `isPrev` nmLhs + -> [] + (Just (ANm_Lhs dn _),Just (ANm_Lhs sn _)) | dn == sn && (isThr nmLhs nmLhs dn) && nmLhs `isPrev` nmLhs + -> [] + _ -> [@self] + | * - Eqn lhs . replCrEqns = [@self] + +SEM ARule + | Rule lhs . self = ARule_Rule @ndNmL @rlNm @info @eqns.replCrEqns + +%%] diff --git a/src/ARule/ElimWildcAssign.cag b/src/ARule/ElimWildcAssign.cag new file mode 100644 --- /dev/null +++ b/src/ARule/ElimWildcAssign.cag @@ -0,0 +1,51 @@ +-- $Id: Ruler.ag 231 2005-06-07 14:39:41Z atze $ + +------------------------------------------------------------------------- +-- Optimisation: Elimination of assignments to wildcard +------------------------------------------------------------------------- + +%%[1 hs module (ARule.ElimWildcAssign) +%%] + +%%[1 hs export (arlElimWild) +%%] + +%%[1 hs import (qualified Data.Map as Map, Common, Expr.Expr, ARule.ARule) +%%] + +%%[1 ag import ({Expr/AbsSynAG}, {ARule/AbsSynAG}) +%%] + +%%[1 ag +WRAPPER AGARuleItf +%%] + +%%[1 hs + +arlElimWild :: ARule -> ARule +arlElimWild rl + = replEw_Syn_AGARuleItf r2 + where r1 = sem_AGARuleItf (AGARuleItf_AGItf rl) + r2 = wrap_AGARuleItf r1 + (Inh_AGARuleItf) +%%] + +------------------------------------------------------------------------- +-- Replica +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllARule AllExpr [ | | replEw: SELF ] +ATTR AGARuleItf [ | | replEw: ARule ] +ATTR AEqns AEqn [ | | replEwEqns USE {++} {[]}: {[AEqn]} ] + +SEM AEqn + | Eqn lhs . replEwEqns = case @dest.replEw of + AEqnDest_One ANm_Wild -> [] + _ -> [@replEw] + | * - Eqn lhs . replEwEqns = [@replEw] + +SEM ARule + | Rule lhs . replEw = ARule_Rule @ndNmL @rlNm @info @eqns.replEwEqns + +%%] diff --git a/src/ARule/EqnDest1NmAG.cag b/src/ARule/EqnDest1NmAG.cag new file mode 100644 --- /dev/null +++ b/src/ARule/EqnDest1NmAG.cag @@ -0,0 +1,24 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- Is lhs a single name? +------------------------------------------------------------------------- + +ATTR AEqnDest [ | | mbSingleANm: {Maybe ANm} ] + +SEM AEqnDest + | One lhs . mbSingleANm = if @lhs.isInComposite then Nothing else Just @anm.self + | Many lhs . mbSingleANm = Nothing + +------------------------------------------------------------------------- +-- Is rhs a single name? +------------------------------------------------------------------------- + +ATTR Expr AExpr [ | | mbSingleANm: {Maybe ANm} ] + +SEM Expr + | AVar lhs . mbSingleANm = Just @anm.self + | * - AppTop Paren AVar + lhs . mbSingleANm = Nothing + +%%] diff --git a/src/ARule/FmGamAG.cag b/src/ARule/FmGamAG.cag new file mode 100644 --- /dev/null +++ b/src/ARule/FmGamAG.cag @@ -0,0 +1,9 @@ +------------------------------------------------------------------------- +-- FmGam +------------------------------------------------------------------------- + +%%[1 ag + +ATTR AGARuleItf AllARule [ fmGam: {FmGam Expr} | | ] + +%%] diff --git a/src/ARule/InCompDestAG.cag b/src/ARule/InCompDestAG.cag new file mode 100644 --- /dev/null +++ b/src/ARule/InCompDestAG.cag @@ -0,0 +1,17 @@ +------------------------------------------------------------------------- +-- Common to other optimisations: is in composite dest? +------------------------------------------------------------------------- + +%%[1 ag + +ATTR AEqnDest AEqnDests [ isInComposite: Bool | | ] + +SEM AEqn + | Eqn dest . isInComposite + = False + +SEM AEqnDest + | Many dests . isInComposite + = True + +%%] diff --git a/src/ARule/OptsAG.cag b/src/ARule/OptsAG.cag new file mode 100644 --- /dev/null +++ b/src/ARule/OptsAG.cag @@ -0,0 +1,9 @@ +------------------------------------------------------------------------- +-- Global info +------------------------------------------------------------------------- + +%%[1 ag + +ATTR AllARule AGARuleItf [ opts: {Opts} | | ] + +%%] diff --git a/src/ARule/PatternUniq.cag b/src/ARule/PatternUniq.cag new file mode 100644 --- /dev/null +++ b/src/ARule/PatternUniq.cag @@ -0,0 +1,109 @@ +------------------------------------------------------------------------- +-- Interfacing to ARule: +------------------------------------------------------------------------- + +%%[1 hs module (ARule.PatternUniq) +%%] + +%%[1 hs export (arlUniq) +%%] + +%%[1 hs import (qualified Data.Set as Set, Common, Opts, ARule.ARule, Expr.Expr, FmGam, ARule.RwSubst) +%%] + +%%[1 ag import ({Expr/AbsSynAG}, {ARule/AbsSynAG}, {Expr/OptsAG}, {ARule/OptsAG}, {Expr/FmGamAG}, {ARule/FmGamAG}, {ARule/CopyRuleNmAG}) +%%] + +%%[1 ag +WRAPPER AGARuleItf +%%] + +%%[1 hs +arlUniq :: FmGam Expr -> [Nm] -> ARule -> ARule +arlUniq fg co rl + = replUniq_Syn_AGARuleItf r2 + where r1 = sem_AGARuleItf (AGARuleItf_AGItf rl) + r2 = wrap_AGARuleItf r1 + (Inh_AGARuleItf {opts_Inh_AGARuleItf = defaultOpts + ,croNmL_Inh_AGARuleItf = co + ,fmGam_Inh_AGARuleItf = fg + }) +%%] + +------------------------------------------------------------------------- +-- Uniq sequence nr +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllARuleButARule AllExpr [ | uniqSeqNr: Int | ] + +SEM ARule + | Rule eqns . uniqSeqNr = 0 + +SEM Expr + | Uniq loc . uniqSeqNr = @lhs.uniqSeqNr + 1 + lhs . uniqSeqNr = @uniqSeqNr + +SEM AGExprItf + | AGItf loc . uniqSeqNr = 0 +%%] + +------------------------------------------------------------------------- +-- Uniq name +------------------------------------------------------------------------- + +%%[1 ag +SEM Expr + | Uniq loc . nm = fmNmUniq @lhs.opts @lhs.fmGam @uniqSeqNr +%%] + +------------------------------------------------------------------------- +-- Node to which uniq thread must be passed +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllARuleRule [ uniqThrDst: ANm | | ] + +SEM AGARuleItf + | AGItf rule . uniqThrDst = case @lhs.croNmL of + (_:[d]) -> ANm_Lhs (fmNmUniq @lhs.opts @lhs.fmGam 0) [] + (_:d:_) -> ANm_Node d (fmNmUniq @lhs.opts @lhs.fmGam 0) +%%] + +------------------------------------------------------------------------- +-- Construction of AEqn for uniq's +------------------------------------------------------------------------- + +%%[1 ag +SEM ARule + | Rule loc . mkUniqEqnL = if @eqns.uniqSeqNr > 0 + then [AEqn_Eqn + (AEqnDest_Many + (map AEqnDest_One + (@lhs.uniqThrDst : [ ANm_Loc (fmNmUniq @lhs.opts @lhs.fmGam u) [] | u <- [1 .. @eqns.uniqSeqNr] ]) + ) + ) + (AExpr_Expr + (mkExprApp (exprSubst (@lhs.opts {optGenFM = FmFmtCmd}) @lhs.fmGam . Expr_Var . nmFunMkUniq $ @eqns.uniqSeqNr) + [mkALhs (fmNmUniq @lhs.opts @lhs.fmGam 0)] + ) + ) + ] + else [] +%%] + +------------------------------------------------------------------------- +-- Replica +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllARule AllExpr [ | | replUniq: SELF ] +ATTR AGARuleItf [ | | replUniq: ARule ] + +SEM ARule + | Rule lhs . replUniq = ARule_Rule @ndNmL @rlNm @info (@mkUniqEqnL ++ @eqns.replUniq) + +SEM Expr + | Uniq lhs . replUniq = mkALoc @nm + +%%] diff --git a/src/ARule/PrettyPrint.cag b/src/ARule/PrettyPrint.cag new file mode 100644 --- /dev/null +++ b/src/ARule/PrettyPrint.cag @@ -0,0 +1,54 @@ +------------------------------------------------------------------------- +-- PP for ARule/Expr +------------------------------------------------------------------------- + +%%[1 hs module (ARule.PrettyPrint) +%%] + +%%[1 hs export (ppARule, ppExpr, ppECGam) +%%] + +%%[1 hs import (qualified Data.Map as Map, UHC.Util.Utils, UHC.Util.Pretty, Common, LaTeXFmtUtils) +%%] + +%%[1 hs import (Expr.Expr, ARule.ARule, ECnstrGam, Config( cfgStrSel )) +%%] + +%%[1 ag import({Expr/AbsSynAG}, {ARule/AbsSynAG}, {Expr/PrettyPrintAG}, {ARule/PrettyPrintAG}, {Expr/SelfAG}, {ARule/SelfAG}) +%%] + +%%[1 ag +WRAPPER AGARuleItf AGExprItf +%%] + +%%[1 hs +ppARule :: ARule -> PP_Doc +ppARule r + = pp_Syn_AGARuleItf r2 + where r1 = sem_AGARuleItf (AGARuleItf_AGItf r) + r2 = wrap_AGARuleItf r1 + (Inh_AGARuleItf) + +ppExpr :: Expr -> PP_Doc +ppExpr e + = pp_Syn_AGExprItf r2 + where r1 = sem_AGExprItf (AGExprItf_AGItf e) + r2 = wrap_AGExprItf r1 + (Inh_AGExprItf) + +ppECGam :: ECnstrGam -> PP_Doc +ppECGam g = vlist [ pp (Expr_Cnstr n v) | (n,v) <- gamAssocs g] + +instance Show ARule where + show _ = "ARule" + +instance PP ARule where + pp = ppARule + +instance Show Expr where + show _ = "Expr" + +instance PP Expr where + pp = ppExpr + +%%] diff --git a/src/ARule/PrettyPrintAG.cag b/src/ARule/PrettyPrintAG.cag new file mode 100644 --- /dev/null +++ b/src/ARule/PrettyPrintAG.cag @@ -0,0 +1,103 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- ARule's PP +------------------------------------------------------------------------- + +ATTR AllARule AGARuleItf [ | | pp USE {>-<} {empty} : PP_Doc ] + +SEM ARule + | Rule lhs . pp = "SEM" >#< pp (head @ndNmL) -- >#< "--" >#< ppCommas' @info + >-< indent atLhs2texDist ("|" >#< @rlNm >|< indent atLhs2texDist @eqns.pp) + +SEM AEqn + | Eqn lhs . pp = let (w1,w2) = fromJust @lhs.mbDstWd + w = w1 + w2 + atDstFillLen + cmb l r = if @dest.isComposite + then if @dest.dstWd > w - atLhs2texDist + then l >-< strWhite w >|< r + else l >|< strWhite (w - @dest.dstWd) >|< r + else l >|< r + in cmb @dest.pp ("=" >|< strWhite atLhs2texDist >|< @val.pp) + | Err lhs . pp = "ERR" >#< @expr.pp + +SEM AEqnDest + | Many lhs . pp = ppParensCommas @dests.ppL + +SEM AExpr + | Expr lhs . pp = exprNeedPar ParCtxtOther nmUnk @expr.self @expr.pp + +SEM AEqnDests [ | | ppL: {[PP_Doc]} ] + | Cons lhs . ppL = @hd.pp : @tl.ppL + | Nil lhs . ppL = [] + +------------------------------------------------------------------------- +-- Context of ANm +------------------------------------------------------------------------- + +SEM AEqnDest + | One anm . isDest = True + +------------------------------------------------------------------------- +-- ARule max column width info, for tabular like PP +------------------------------------------------------------------------- + +ATTR AllARuleButARule [ mbDstWd: {Maybe (Int,Int)} | | mxDstNdWd, mxDstAtWd USE {`max`} {0}: Int ] + +SEM ARule + | Rule loc . mbDstWd = Just (@eqns.mxDstNdWd,@eqns.mxDstAtWd) + +SEM AEqnDest + | Many dests . mbDstWd = Nothing + +------------------------------------------------------------------------- +-- ARule dest width info, for lining up multidestination AEqn +------------------------------------------------------------------------- + +ATTR AEqnDest [ | | dstWd: Int ] +ATTR AEqnDests [ | | dstWdL: {[Int]} ] + +SEM AEqnDest + | Many lhs . dstWd = sum @dests.dstWdL + length @dests.dstWdL + 1 + | One lhs . dstWd = @anm.mxDstNdWd + @anm.mxDstAtWd + (if @anm.mxDstNdWd > 0 then 1 else 0) + +SEM AEqnDests + | Cons lhs . dstWdL = @hd.dstWd : @tl.dstWdL + | Nil lhs . dstWdL = [] + +------------------------------------------------------------------------- +-- Node name of AEqnDest in an AEqn, for emitting only first of a series of same node names +------------------------------------------------------------------------- + +ATTR AEqnDest AEqn [ | | ndStr: String ] +ATTR AEqnDest AEqn AEqns [ mbPrevNdStr: {Maybe String} | | ] + +SEM AEqnDest + | Many lhs . ndStr = "??" + +SEM AEqn + | Err lhs . ndStr = "??" + +SEM AEqns + | Cons tl . mbPrevNdStr = fmap (const @hd.ndStr) @lhs.mbDstWd + +SEM ARule + | Rule loc . mbPrevNdStr = Nothing + +SEM AEqnDests + | Cons loc . mbPrevNdStr = Nothing + +SEM AEqnDest + | Many loc . mbPrevNdStr = Nothing + +------------------------------------------------------------------------- +-- Kind of lhs of eqn, composite? +------------------------------------------------------------------------- + +ATTR AEqnDest [ | | isComposite: Bool ] + +SEM AEqnDest + | Many lhs . isComposite = True + | One lhs . isComposite = False + +%%] diff --git a/src/ARule/RwSubst.cag b/src/ARule/RwSubst.cag new file mode 100644 --- /dev/null +++ b/src/ARule/RwSubst.cag @@ -0,0 +1,429 @@ +------------------------------------------------------------------------- +-- ARule/Expr substitution/rewrite +------------------------------------------------------------------------- + +%%[1 hs module (ARule.RwSubst) +%%] + +%%[1 hs export (exprSubst, exprElimCnstr, exprRewrite', exprRewrite, arlSubst, nmSubst, MtOut(..), exprMatch, fmNmUniq, fmNmFmtCmd) +%%] + +%%[1 hs import (Data.List, qualified Data.Set as Set, qualified Data.Map as Map, UHC.Util.Pretty) +%%] + +%%[1 hs import (UHC.Util.Utils, Common, Opts, Expr.Expr, Expr.IsRw, Expr.ToAEqn, ARule.ARule) +%%] + +%%[1 hs import (ARule.PrettyPrint, FmGam, ECnstrGam, RwExprGam) +%%] + +%%[1 ag import ({Expr/AbsSynAG}, {ARule/AbsSynAG}) +%%] + +%%[1 ag import ({Expr/OptsAG}, {ARule/OptsAG}) +%%] + +%%[1 ag import ({Expr/FmGamAG}, {ARule/FmGamAG}) +%%] + +%%[1 ag import ({Expr/RwExprGamAG}) +%%] + +%%[1 ag +WRAPPER AGExprItf AGARuleItf +%%] + +%%[1 hs +wrapARule' :: Opts -> {- [Nm] -> AtDefdGam -> -} FmGam Expr -> ARule -> Syn_AGARuleItf +wrapARule' o {- co ag -} fg rl + = let r1 = sem_AGARuleItf (AGARuleItf_AGItf rl) + in wrap_AGARuleItf r1 + (Inh_AGARuleItf {opts_Inh_AGARuleItf = o + -- ,croNmL_Inh_AGARuleItf = co + -- ,adGam_Inh_AGARuleItf = ag + ,fmGam_Inh_AGARuleItf = fg + }) + +arlSubst :: FmGam Expr -> ARule -> ARule +arlSubst fg = repl_Syn_AGARuleItf . wrapARule' defaultOpts {- [] emptyGam -} fg +%%] + +%%[1 hs +wrapExpr' :: Opts -> FmGam Expr -> RwExprGam -> ECnstrGam -> {- RnMp -> -} Expr -> Syn_AGExprItf +wrapExpr' o fmg rwg ecg {- rnm -} e + = let r1 = sem_AGExprItf (AGExprItf_AGItf e) + in wrap_AGExprItf r1 + (Inh_AGExprItf { opts_Inh_AGExprItf = o + , fmGam_Inh_AGExprItf = fmg, rwGam_Inh_AGExprItf = rwg, ecGam_Inh_AGExprItf = ecg + -- , rnMp_Inh_AGExprItf = rnm + }) + +exprSubst :: Opts -> FmGam Expr -> Expr -> Expr +exprSubst o fmg = repl_Syn_AGExprItf . wrapExpr' o fmg emptyGam emptyGam {- Map.empty -} + +exprElimCnstr :: Expr -> (Expr,ECnstrGam) +exprElimCnstr e + = (replEc_Syn_AGExprItf r,ecElimGam_Syn_AGExprItf r) + where r = wrapExpr' defaultOpts emptyGam emptyGam emptyGam {- Map.empty -} e + +exprRewrite :: Opts -> FmGam Expr -> RwExprGam -> ECnstrGam -> Expr -> Expr +exprRewrite o fmg rwg ecg e + = r + where (r,_,_) = exprRewrite' o fmg rwg ecg e + +exprRewrite' :: Opts -> FmGam Expr -> RwExprGam -> ECnstrGam -> Expr -> (Expr,[AEqn],FmGam Expr) +exprRewrite' o fmg rwg ecg e + = (repl_Syn_AGExprItf r,aEqnL_Syn_AGExprItf r,aEqnFmGam_Syn_AGExprItf r) + where r = wrapExpr' o fmg rwg ecg {- Map.empty -} e + +nmSubst :: Opts -> FmGam Expr -> Nm -> Nm +nmSubst o g = exprAsNm . exprSubst o g . Expr_Var + +%%] + +------------------------------------------------------------------------- +-- Derived +------------------------------------------------------------------------- + +%%[1 hs +fmNmUniq :: Opts -> FmGam Expr -> Int -> Nm +fmNmUniq o g u = nmSubst (o {optGenFM = FmAG}) g (nmUniq u) + +fmNmFmtCmd :: Opts -> FmGam Expr -> Nm -> Nm +fmNmFmtCmd o g n = nmSubst (o {optGenFM = FmFmtCmd}) g n + +%%] + +------------------------------------------------------------------------- +-- ecGam +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllExprButANm AGExprItf [ ecGam: ECnstrGam | | ] +%%] + +------------------------------------------------------------------------- +-- Defaults for gam's +------------------------------------------------------------------------- + +%%[1 ag +SEM AEqn + | Err loc . fmGam = emptyGam + . rwGam = emptyGam + . ecGam = emptyGam + +SEM AExpr + | Expr loc . rwGam = emptyGam + . ecGam = emptyGam +%%] + +------------------------------------------------------------------------- +-- Variable substition (merged with rewriting) +------------------------------------------------------------------------- + +%%[1 hs +nmMatch :: Opts -> FmKind -> Nm -> FmGam Expr -> Maybe ([Maybe String],[Maybe String],Expr) +nmMatch opts fk n fmGam + = match + where nmL = nmToMbL n + nmLen = length nmL + nLL + = if optSubstFullNm opts + then [nmL] + else reverse . tail . inits $ nmL + match + = foldr (\nL m + -> case fmGamLookup (nmFromMbL nL) fk fmGam of + Just e | isOkLen + -> Just (nL,drop len nmL,e) + where isOkLen = maybe True (\n -> len == length (nmToMbL n) || len == nmLen) (mbNmOfSel e) + len = length nL + _ -> m + ) + Nothing nLL + +nmLAsSelExpr :: (Expr -> Expr) -> Expr -> [Maybe String] -> Expr +nmLAsSelExpr subst e nL + = case nL of + [] -> e + _ -> Expr_SelTop . foldl Expr_Sel e $ eL + where eL = map (fmap (subst . Expr_Var . Nm)) nL + +mbNmOfSel :: Expr -> Maybe Nm +mbNmOfSel e + = t e + where t (Expr_SelTop st) = n st + t e = exprMbNm e + n (Expr_Sel se (Just (Expr_Var (Nm s)))) = fmap (\n -> NmSel n (Just s)) (n se) + n (Expr_Sel se Nothing) = fmap (\n -> NmSel n Nothing) (n se) + n (Expr_Var n) = Just n + n _ = Nothing + +mbNmLOfSel :: Expr -> Maybe [Maybe String] +mbNmLOfSel = fmap nmToMbL . mbNmOfSel + +exprVarSubst :: Opts -> FmGam Expr -> RwExprGam -> ECnstrGam -> Expr -> Nm -> Expr +exprVarSubst opts fmGam rwGam ecGam dfltRepl nm + = case nmMatch opts (optGenFM opts) nm fmGam of + Just (matchNmL,remNmL,matchExpr) + -> case mbNmLOfSel se of + Just sNmL + -> Expr_Var (nmFromMbL (sNmL ++ remNmL)) + _ -> nmLAsSelExpr id se remNmL + where se = if optSubstOnce opts then matchExpr else sbsWoNm matchExpr + sbsWoNm = exprSubst opts (nmFromMbL matchNmL `gamDelete` fmGam) + _ -> dfltRepl +%%] + +%%[1 ag +ATTR AllExpr ANm AllARule [ | | repl: SELF ] +ATTR AGExprItf [ | | repl: Expr ] +ATTR AGARuleItf [ | | repl: ARule ] + +SEM Expr + | Var loc . replVar = exprVarSubst @lhs.opts @lhs.fmGam @lhs.rwGam @lhs.ecGam @repl @nm + . (replEcVar,varEcGam) + = exprElimCnstr @replVar + +SEM ECnstr + | Var lhs . repl = case nmMatch @lhs.opts FmCnstr @nm @lhs.fmGam of + Just (_,_,Expr_WrapCnstr c) + -> c + _ -> @repl +%%] + +------------------------------------------------------------------------- +-- Rewriting (merged with variable substition) +------------------------------------------------------------------------- + +%%[1 hs +mkRwExpr :: InEqnLoc -> Opts -> FmGam Expr -> RwExprGam -> ECnstrGam -> Expr -> (Expr,FmGam Expr,ECnstrGam) +mkRwExpr inEqnLoc opts fmGam rwGam ecGam repl + = case exprIsRw repl of + ExprIsRw n | isJust mbRw + -> (r,mtFmGam mt,ecg) + where mbRw = rwGamLookup n (optGenFM opts) (if inEqnLoc == EqnInRhs then AtIn else AtOut) rwGam + (r,mt,ecg) + = foldr (\(me,e) r + -> let mt = exprMatch opts ecGam repl me + in if mtMatches mt + then let e2 = exprSubst opts (mtFmGam mt `gamUnion` fmGam) e + (e3,ecg) = exprElimCnstr e2 + in (e3,mt,ecg) + else r + ) + (repl,emptyEMtOut,emptyGam) + (maybe (panic "mkRwExpr") (\x -> x) mbRw) + _ -> (repl,emptyGam,emptyGam) +%%] + +-- with tracing +mkRwExpr :: InEqnLoc -> Opts -> FmGam Expr -> RwExprGam -> ECnstrGam -> Expr -> (Expr,FmGam Expr,ECnstrGam) +mkRwExpr inEqnLoc opts fmGam rwGam ecGam repl + = case exprIsRw (d_r repl) of + ExprIsRw n | isJust mbRw + -> (r,mtFmGam mt,ecg) + where mbRw = rwGamLookup n (optGenFM opts) (if inEqnLoc == EqnInRhs then AtIn else AtOut) rwGam + (r,mt,ecg) + = foldr (\(me,e) r + -> let mt = exprMatch opts ecGam repl me + in if mtMatches mt + then let e2 = exprSubst opts (mtFmGam mt `gamUnion` fmGam) e + (e3,ecg) = exprElimCnstr e2 + in (e3,mt,ecg) + else r + ) + (repl,emptyEMtOut,emptyGam) + (maybe (panic "mkRwExpr") (\x -> trp "mkRwExpr matches" (d_g x) x) mbRw) + _ -> (repl,emptyGam,emptyGam) + where d_r r = trp "mkRwExpr expr" (pp r >-< pp (exprIsRw r)) r + d_g g = vlist . map (\(a,b) -> pp a >#< "//" >#< pp b) $ g + +%%[1 ag +ATTR AllExpr AGExprItf [ | | rwMtGam USE {`fmGamUnion`} {emptyGam}: {FmGam Expr} ] +ATTR AllExpr AGExprItf [ | | rwEcGam USE {`gamUnion`} {emptyGam}: {ECnstrGam} ] + +SEM Expr + | Var loc . forRwEcGam = @varEcGam `gamUnion` @lhs.ecGam + (lhs.repl,lhs.rwMtGam,loc.rwEcGam) + = mkRwExpr @lhs.inEqnLoc @lhs.opts @lhs.fmGam @lhs.rwGam (@forRwEcGam) @replEcVar + lhs . rwEcGam = @rwEcGam `gamUnion` @varEcGam + | AppTop loc . forRwEcGam = @expr.rwEcGam `gamUnion` @lhs.ecGam + (loc.rwRepl,loc.rwMtGam,loc.rwEcGam) + = mkRwExpr @lhs.inEqnLoc @lhs.opts @lhs.fmGam @lhs.rwGam (@forRwEcGam) @repl + lhs . rwMtGam = @rwMtGam `fmGamUnion` @expr.rwMtGam + . rwEcGam = @rwEcGam `gamUnion` @expr.rwEcGam + . repl = @rwRepl +%%] + +------------------------------------------------------------------------- +-- Resulting AEqn's +------------------------------------------------------------------------- + +%%[1 ag +ATTR Expr AGExprItf [ | | aEqnL USE {++} {[]}: {[AEqn]} ] + +SEM Expr + | AppTop (lhs.aEqnL,loc.aEqnFmGam) + = case exprMbAEqnRest @rwRepl of + Just (aEqn,remEqnL,fmGam) | @expr.isEqnAtEql + -> (aEqn : concat rwEqnL, fmGam `fmGamUnion` fmGamUnions fmGamL) + where (rwEqnL,fmGamL) + = unzip [ (e,g) | eqn <- remEqnL, let (_,e,g) = exprRewrite' @lhs.opts @lhs.fmGam @lhs.rwGam @lhs.ecGam eqn ] + _ -> ([AEqn_Err @rwRepl],emptyGam) +%%] + +------------------------------------------------------------------------- +-- Additional subst for names +------------------------------------------------------------------------- + +%%[1 ag +ATTR Expr AGExprItf [ | | aEqnFmGam USE {`fmGamUnion`} {emptyGam}: {FmGam Expr} ] +%%] + +------------------------------------------------------------------------- +-- Context for use in rewriting +------------------------------------------------------------------------- + +%%[1 hs +data InEqnLoc + = EqnInTop | EqnInLhs | EqnInRhs + deriving (Show,Eq,Ord) +%%] + +%%[1 ag +ATTR AllExprButANm [ inEqnLoc: InEqnLoc | | ] +ATTR Expr [ | | isEqnAtEql: Bool ] + +SEM Expr + | Op loc . isEqnAtEql = @lhs.inEqnLoc == EqnInTop && @nm == nmEql + (lExpr.inEqnLoc,rExpr.inEqnLoc) + = if @isEqnAtEql + then (EqnInLhs,EqnInRhs) + else (@lhs.inEqnLoc,@lhs.inEqnLoc) + | * - Op Paren Named + lhs . isEqnAtEql = False + +SEM AGExprItf + | AGItf expr . inEqnLoc = EqnInTop + +SEM AExpr + | Expr loc . inEqnLoc = EqnInTop + +SEM AEqn + | Err loc . inEqnLoc = EqnInTop +%%] + +------------------------------------------------------------------------- +-- Matching +------------------------------------------------------------------------- + +%%[1 hs +data MtOut e + = MtOut {mtMatches :: Bool, mtExpr :: e, mtFmGam :: FmGam Expr} + +instance Show (MtOut e) where + show _ = "MtOut" + +instance PP e => PP (MtOut e) where + pp i = "Mt" >#< pp (mtMatches i) >#< pp (mtExpr i) >#< ppGam (mtFmGam i) + +emptyMtOut e = MtOut {mtMatches = True, mtExpr = e, mtFmGam = emptyGam} +emptyEMtOut = emptyMtOut Expr_Empty +emptyCMtOut = emptyMtOut ECnstr_Empty + +-- lhs into rhs matching, expects rhs, given lhs +exprMatch :: Opts -> ECnstrGam -> Expr -> Expr -> MtOut Expr +exprMatch opts ecGam e1 e2 + = r + where r = mt e1 e2 + -- r' = trp "XX" (pp e1 >-< pp e2 >-< pp r) $ r + mt (Expr_Int i1) e2@(Expr_Int i2) | i1 == i2 = res e2 + mt (Expr_StrText s1) e2@(Expr_StrText s2) | s1 == s2 = res e2 + mt (Expr_StrAsIs s1) e2@(Expr_StrAsIs s2) | s1 == s2 = res e2 + mt (Expr_Empty) (Expr_Empty) = res Expr_Empty + mt (Expr_AppTop e1) (Expr_AppTop e2) = let m = mt e1 e2 in res' (Expr_AppTop (mtExpr m)) m + mt (Expr_Paren e1) (Expr_Paren e2@(Expr_Var n2)) = bnd n2 e1 $ res e2 + mt (Expr_Paren e1) e2@(Expr_Var n2) = bnd n2 e1 $ res e2 + mt (Expr_Paren e1) (Expr_Paren e2) = let m = mt e1 e2 in res' (Expr_Paren (mtExpr m)) m + mt e1 (Expr_Paren e2) = mt e1 e2 + mt (Expr_Op n1 ne1 l1 r1) e2@(Expr_Var n2) | not (optMatchROpOpnd opts) + = err + mt e1 e2@(Expr_Var n2) = bnd n2 e1 $ res e2 + mt (Expr_Op n1 ne1 l1 r1) (Expr_Op n2 ne2 l2 r2) | n1 == n2 + = bnd' (m2 {mtFmGam = n1 `gamDelete` mtFmGam m2}) m1 + where m1 = app l1 l2 r1 r2 (\l r -> Expr_Op n2 ne2 l r) + m2 = mt ne1 ne2 + mt (Expr_App l1 r1) (Expr_App l2 r2) = app l1 l2 r1 r2 Expr_App + mt (Expr_SelTop t1) e2@(Expr_SelTop t2) = bnd' (mt t1 t2) $ res e2 + mt (Expr_Sel e1 (Just s1)) (Expr_Sel e2 (Just s2)) = app e1 e2 s1 s2 (\l r -> Expr_Sel l (Just r)) + mt (Expr_Named n e1) e2 = let m = mt e1 e2 in res' (Expr_Named n (mtExpr m)) m + mt e1 (Expr_Cnstr e2 c2) + = case ecGamLookup e1 ecGam of + Just c1 | mtMatches mc + -> bnd' mc $ mt e1 e2 + where mc = mtc c1 c2 + _ -> err + mt _ _ = err + mtc (ECnstr_Ty t1) c2@(ECnstr_Ty t2) | not (null t) + = resc (ECnstr_Ty t) + where t = t1 `intersect` t2 + mtc c1 c2@(ECnstr_Var n2) = bndc n2 c1 $ resc c2 + mtc _ _ = errc + app l1 l2 r1 r2 mk + = foldr1 (\m1 m2 -> if mtMatches m1 then m2 else m1) [ml,mr,m] + where ml = mt l1 l2 + mr = mt r1 r2 + m = bnd' ml . res' (mk (mtExpr ml) (mtExpr mr)) $ mr + bnd' :: MtOut e' -> MtOut e -> MtOut e + bnd' mn m = m {mtFmGam = mtFmGam mn `fmGamUnion` mtFmGam m} + bnd n e m = bnd' (emptyEMtOut {mtFmGam = fmSingleton n FmAll e}) m + bndc n e m = bnd' (emptyCMtOut {mtFmGam = fmSingleton n FmCnstr (Expr_WrapCnstr e)}) m + res' :: e -> MtOut e' -> MtOut e + res' e m = m {mtExpr = e} + res e = res' e emptyEMtOut + resc e = res' e emptyEMtOut + err' :: MtOut e -> MtOut e + err' m = m {mtMatches = False} + err = err' emptyEMtOut + errc = err' emptyCMtOut +%%] + +------------------------------------------------------------------------- +-- Elimination of Expr_Cnstr +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllExpr ANm [ | | replEc: SELF ] +ATTR AGExprItf [ | | replEc: Expr ] +ATTR AGExprItf AllExpr [ | | ecElimGam USE {`gamUnion`} {emptyGam}: ECnstrGam ] + +SEM Expr + | Cnstr lhs . replEc = @expr.replEc + . ecElimGam = ecGamInsert @expr.replEc @cnstr.replEc @expr.ecElimGam + +%%] + +------------------------------------------------------------------------- +-- Disable case-optimizations of the AG system for this AG file +-- +-- Required: +-- * exprElimCnstr emulates an higher-order Expr attribute, of an Expr, +-- which effectively constructs an infintely-deep nested tree (normally +-- not in practice, because depending on a stop-criterium, none of the +-- synthesized attributes of this higher-order attribute are used, which +-- effectively stops the iteration process. +-- * it has two synthesized attributes, the 'eliminated' expr, and some +-- environment varEcGam. +-- * the function mkRwExpr contains the stop criterium. It is parameterized +-- with the environment of the next iteration, but will not touch it if +-- the stop-criterium applies: in that case it used an empty environment. +-- * unfortunately, the case-optimizations puts the environment varEcGam as +-- scrutenee of a case expression and it is forced during evaluation +-- (which is wrong). It subsequently triggers the evaluation of the next +-- iteration, bypassing the stop criterium, and causing an infinite loop. +------------------------------------------------------------------------- + +%%[1 ag +PRAGMA nocase +%%] diff --git a/src/ARule/SelfAG.cag b/src/ARule/SelfAG.cag new file mode 100644 --- /dev/null +++ b/src/ARule/SelfAG.cag @@ -0,0 +1,10 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- Self +------------------------------------------------------------------------- + +ATTR AllARule [ | | self: SELF ] +ATTR AGARuleItf [ | | self: ARule ] + +%%] diff --git a/src/ARule/Utils.chs b/src/ARule/Utils.chs new file mode 100644 --- /dev/null +++ b/src/ARule/Utils.chs @@ -0,0 +1,31 @@ +------------------------------------------------------------------------- +-- Interface to all ARule transformations and other utilities +------------------------------------------------------------------------- + +%%[1 hs module (ARule.Utils) +%%] + +%%[1 hs export (module ARule.ARule, module ARule.PatternUniq, module ARule.RwSubst, module ARule.AVarRename) +%%] + +%%[1 hs export (module ARule.ElimCopyRule, module ARule.ElimWildcAssign, module ARule.PrettyPrint) +%%] + +%%[1 hs export (exprFmtTeXSubst) +%%] + +%%[1 hs import (UHC.Util.Pretty, Common, Opts, FmGam, Expr.Expr, Expr.LaTeX) +%%] + +%%[1 hs import (ARule.ARule, ARule.PatternUniq, ARule.RwSubst, ARule.AVarRename) +%%] + +%%[1 hs import (ARule.ElimCopyRule, ARule.ElimWildcAssign, ARule.PrettyPrint) +%%] + +%%[1 hs + +exprFmtTeXSubst :: Opts -> FmGam Expr -> Expr -> PP_Doc +exprFmtTeXSubst o fmg = exprFmtTeX o fmg . exprSubst o fmg + +%%] diff --git a/src/AS1/GenAS2.cag b/src/AS1/GenAS2.cag new file mode 100644 --- /dev/null +++ b/src/AS1/GenAS2.cag @@ -0,0 +1,237 @@ +------------------------------------------------------------------------- +-- Utils +------------------------------------------------------------------------- + +%%[1 hs +rsSelect :: RlSelIsSel -> RsGam Expr -> [(Nm,RsInfo Expr)] +rsSelect rlSelIsSel rsGam + = rs + where rs = [ (rsNm,rsInfo {rsRlGam = gamFromAssocs rls}) + | (rsNm,rsInfo) <- gamAssocsShadow rsGam + , rsInfoIsPlain rsInfo + , rlSelIsSel nmAny rsNm nmAny + , let rls + = [ (rlNm,rlInfo {rlVwGam = gamFromAssocs vws}) + | (rlNm,rlInfo) <- gamAssocsShadow (rsRlGam rsInfo) + , rlSelIsSel nmAny nmAny rlNm + , let vws + = [ v + | v@(vwNm,_) <- gamAssocsShadow (rlVwGam rlInfo) + , rlSelIsSel vwNm nmAny nmAny + ] + , not (null vws) + ] + , not (null rls) + ] + +rsSelectGroup :: RlSelIsSel -> RsGam Expr -> [(Nm,RsInfo Expr)] +rsSelectGroup rlSelIsSel rsGam + = rs + where rs = [ (rsNm,rsInfo {rsRlNms = rlNms}) + | (rsNm,rsInfo) <- gamAssocsShadow rsGam + , rsInfoIsGroup rsInfo + , rlSelIsSel nmAny rsNm nmAny + , let rlNms + = [ r | r@(nRs,nRl) <- rsRlNms rsInfo, rlSelIsSel nmAny nRs nRl ] + , not (null rlNms) + ] + +scSelect :: RlSelIsSel -> ScGam Expr -> [(Nm,ScInfo Expr)] +scSelect rlSelIsSel scGam + = sc + where sc = [ (scNm,scInfo {scVwGam = gamFromAssocs vws}) + | (scNm,scInfo) <- gamAssocsShadow scGam + -- , rlSelIsSel nmAny rsNm nmAny + , let vws + = [ v + | v@(vwNm,_) <- gamAssocsShadow (scVwGam scInfo) + , rlSelIsSel vwNm nmAny nmAny + ] + ] + +jdChangeInfo :: Opts -> (Nm -> Maybe Bool) -> FmGam Expr -> (FmGam Expr,Expr->Expr) +jdChangeInfo opts isChgd jaFmGam + = if null chs then (jaFmGam,id) + else if or chs then (fmGamMap mkChng jaFmGam,id) + else (jaFmGam,Expr_Wrap WrIsSame) + where chs = catMaybes . map isChgd . gamKeys $ jaFmGam + mkChng + = case optMbMarkChange opts of + Just _ -> \nAt -> case isChgd nAt of + Just isCh -> Expr_Wrap (if isCh then WrIsChanged else WrIsSame) + Nothing -> id + Nothing -> \_ -> id + +atIsChanged :: VwRlInfo Expr -> Nm -> Nm -> Maybe Bool +atIsChanged vwRlInfo + = case vwrlMbChGam vwRlInfo of + Just g -> \j a -> maybe (Just False) (const (Just True)) $ dblGamLookup id j a g + Nothing -> \_ _ -> Nothing +%%] + +%%[1 ag + +------------------------------------------------------------------------- +-- Selection +------------------------------------------------------------------------- + +SEM AGItf + | AGItf loc . rsSelected = rsSelect @rlSelIsSel @rsGam + . scSelected = scSelect @rlSelIsSel @scGam + . rsGrpSelected + = rsSelectGroup @rlSelIsSel @rsGam + +------------------------------------------------------------------------- +-- Generate AS2 +------------------------------------------------------------------------- + +ATTR AGItf [ | | as2: {AS2.Decls} ] + +SEM AGItf + | AGItf loc . fmAS2 = fmAS2Fm (optGenFM @lhs.opts) + lhs . as2 = @as2Preamble ++ @as2ScmMeta ++ @as2RuleSets ++ @as2Explain + +------------------------------------------------------------------------- +-- Generate AS2 for scheme related (meta) info +------------------------------------------------------------------------- + +SEM AGItf + | AGItf loc . rsMetaSel = let nVwS = dgVertices @vwDpdGr + in gamFromAssocsWith Set.union + [ (rsScNm i,vs) | i <- gamElemsShadow @rsGam + , let vs = Set.filter (\v -> @rlSelIsSel v (rsNm i) nmAny) nVwS, not (Set.null vs) + ] + . mkWrapChunk = \ag s v -> AS2.wrapInChunk AS2.Decl_Chunk @lhs.opts (rsSelMapVwNm (optMbRlSel @lhs.opts) v `nmApd` s `nmApd` Nm ag) + . as2ScmATTR = let mkChunk = @mkWrapChunk "ATTR" + mk s v + = case scVwGamLookup s v @scGam of + Just (si,vi) | not (gamIsEmpty agi && gamIsEmpty agsi && gamIsEmpty ags) + -> [AS2.Decl_AttrAG (AS2.AttrAGDecl_Attr (sc2DATA si @dtInvGam) (mkg agi) (mkg agsi) (mkg ags))] + where ag1 = gamFilter (\ai -> AtNode `notElem` atProps ai) (vwscFullAtGam vi) + (agsi,ag2) = gamPartition (\ai -> isJust (atMbSynInh ai)) ag1 + (ags,agi) = gamPartition (\ai -> AtSyn `atHasDir` ai) ag2 + mkg g = gamAssocsShadow $ gamFromAssocs + $ [ (n,atTy ai) | ai <- gamElemsShadow g, let n = nmSubst @lhs.opts @fmGam $ maybe (atNm ai) id $ atMbSynInh ai ] + _ -> [] + in [ mkChunk s v d | (s,vs) <- gamAssocsShadow @rsMetaSel, v <- Set.toList vs, d <- mk s v ] + . as2ScmDATA = let mkChunk = @mkWrapChunk "DATA" + mk s v + = case scVwGamLookup s v @scGam of + Just (si,vi) | not (null alts) + -> [AS2.Decl_DataAG (AS2.DataAGDecl_Data dtNm alts)] + where dtNm = sc2DATA si @dtInvGam + alts + = case dtVwGamLookup dtNm v @dtGam of + Just (dtInfo,dtVwInfo) + -> [ AS2.DataAGAlt_Alt a + [ AS2.DataAGFld_Fld (nmSubst @lhs.opts @fmGam f) (dfTy fi) (tyIsDef (tyTopNm $ dfTy fi)) + | (f,fi) <- sortOn (dfSeqNr . snd) $ gamAssocs $ daFldGam ai + ] + | (a,ai) <- gamAssocs (vdFullAltGam dtVwInfo) + ] + where tyIsDef t = maybe False (const True) $ dtVwGamLookup t v @dtGam + _ -> [] + _ -> [] + in [ mkChunk s v d | (s,vs) <- gamAssocsShadow @rsMetaSel, v <- Set.toList vs, d <- mk s v ] + . as2ScmMeta = if @fmAS2 == FmAG || @fmAS2 == FmHS + then (if optGenAGData @lhs.opts then @as2ScmDATA else []) + ++ (if optGenAGAttr @lhs.opts then @as2ScmATTR else []) + else [] + +------------------------------------------------------------------------- +-- Generate AS2 for rulesets +------------------------------------------------------------------------- + +SEM AGItf + | AGItf loc . as2RuleSets = let topWrap d = [AS2.Decl_RsVw d] + mkRs rsInfo + = case rsInfo of + RsInfo nRs _ nSc vwSel d rlGam + -> topWrap + $ AS2.RsVwDecl_Rs nRs nSc d + [ AS2.VwDecl_Vw v (mkFullVwNm nRs v) rls' + | (v,rls) <- gamAssocsShadow rlGamT + , let rls' = catMaybes [ gamLookup n rls | n <- rlOrder ] + ] + where rlGamT = gamTranspose (rlVwGam,mkRl) rlGam + rlOrder = rsRlOrder rsInfo + jdsOf o g = [ maybe (panic "as2RuleSets") id (gamLookup jNm g) | jNm <- o ] + mkRl nRl nVw rlInfo vwRlInfo + = mkChunk nVw rlInfo + $ AS2.RlDecl_Rl nRl fullNm (rlPos rlInfo) (rl2SEM rlInfo @dtInvGam nSc nRl nVw) pre post + where preg = vwrlFullPreGam vwRlInfo + postg = vwrlFullPostGam vwRlInfo + preOrder = concat (vwrlPreScc vwRlInfo) + postOrder = gamKeys postg + (pre,post) + = case @fmAS2 of + FmTeX -> (mkExprJds vwRlInfo preOrder preg,mkExprJds vwRlInfo postOrder postg) + FmAG -> (mkAtsJds preOrder preg,mkAtsJds postOrder postg) + _ -> ([],[]) + fullNm = mkFullRlNm nRs nVw nRl + mkChunk nVw rlInfo + = AS2.wrapInChunk AS2.RlDecl_Chunk @lhs.opts (nVwRnm `nmApd` nSc `nmApd` rlNm rlInfo) + where nVwRnm = rsSelMapVwNm (optMbRlSel @lhs.opts) nVw + mkAtsJds order reGam + = [ AS2.Jd_Ats (reNm jInfo) (reScNm jInfo) (mkAts jInfo) | jInfo <- jdsOf order reGam ] + where mkAts jInfo = [ AS2.JdAt_At aNm (jaExpr a) | (aNm,a) <- gamAssocsShadow (reJAGam jInfo) ] + mkExprJds vwRlInfo order reGam + = [ AS2.Jd_Expr (reNm jInfo) (reScNm jInfo) (mkExpr vwRlInfo jInfo) (reIsSmall jInfo) | jInfo <- jdsOf order reGam ] + where mkExpr vwRlInfo jInfo + = wrapFullJd $ exprSubst (@lhs.opts {optSubstOnce=True}) jg' $ e + where (scInfo,vwScInfo) = fromJust (scVwGamLookup (reScNm jInfo) nVw @scGam) + jg = jaGamToFmGam id . reJAGam $ jInfo + (jg',wrapFullJd) = jdChangeInfo @lhs.opts (atIsChanged vwRlInfo (reNm jInfo)) jg + e = jdGamFmExpr @fmAS2 . vwscJdShpGam $ vwScInfo + nVw = vwrlNm vwRlInfo + RsInfoGroup nRs _ nSc vwSel d rlNms | @fmAS2 == FmTeX + -> topWrap + $ AS2.RsVwDecl_Rs nRs nSc d + [ AS2.VwDecl_Vw nVw (mkFullVwNm nRs nVw) (mkRls nVw rlNms) | nVw <- vwOrder ] + where vwOrder = [ v | v <- dgTopSort @vwDpdGr, @rlSelIsSel v nmAny nmAny ] + mkRls nVw rlNms + = [ AS2.RlDecl_LTXAlias (mkFullRlNm nRs nVw nRl) (mkFullRlNm nRs' nVw nRl) + | (nRs',nRl) <- rlNms, rlVwIsDef nRs' nVw nRl + ] + rlVwIsDef nRs nVw nRl + = isJust (do rsInfo <- gamLookup nRs @rsGam + rlGam <- rsInfoMbRlGam rsInfo + rlVwGamLookup nRl nVw rlGam + ) + _ -> [] + mkFullVwNm nRs nVw = nmApd (Nm (optBaseNm @lhs.opts)) $ (if nVw == nmNone then id else nmApd nVw) $ nRs + mkFullRlNm nRs nVw nRl = mkFullVwNm nRs nVw `nmApd` {- mkRlNm -} nRl + mkRlNm = if optDot2Dash @lhs.opts then nmDashed else nmFlatten + in [ d | (nRs,rsInfo) <- @rsSelected ++ @rsGrpSelected, d <- mkRs rsInfo ] + +------------------------------------------------------------------------- +-- Generate AS2 for explain (i.e. explanation) +------------------------------------------------------------------------- + +SEM AGItf + | AGItf loc . as2Explain = if optGenExpl @lhs.opts + then let explGen + = [ ex | (nSc,scInfo) <- @scSelected, exSc <- mkSc scInfo, ex <- exSc ] + where mkSc scInfo + = [ (maybe [] (\e -> [mkChunk nVw "explain.scheme" $ AS2.Decl_ScVwExplain (fmtex e)]) . gamLookup nmNone . vwscExplGam $ vwInfo) + ++ [ mkChunk nVw "explain.holes" $ AS2.Decl_ScVwAtExplain + $ [ (fmte $ Expr_Expr $ Expr_Var $ n, fmtex ei) | (n,ei) <- gamAssocsShadow (vwscExplGam vwInfo `Map.intersection` vwscFullAtGam vwInfo) ] + ] + | (nVw,vwInfo) <- gamAssocsShadow (scVwGam scInfo) + ] + where mkChunk nVw n = AS2.wrapInChunk AS2.Decl_Chunk @lhs.opts (scNm scInfo `nmApd` nVw `nmApd` Nm n) + fmte = exprSubst (@lhs.opts {optSubstFullNm=False, optGenFM = FmTeX}) @fmGam + fmtex = fmte . explExpr + in explGen + else [] + +------------------------------------------------------------------------- +-- Generate AS2 for preamble +------------------------------------------------------------------------- + +SEM AGItf + | AGItf loc . as2Preamble = if optPreamble @lhs.opts + then fkGamLookup [] (\p -> [AS2.Decl_Preamble p]) [@fmAS2] @decls.paGam + else [] + +%%] diff --git a/src/AS1/Imports.cag b/src/AS1/Imports.cag new file mode 100644 --- /dev/null +++ b/src/AS1/Imports.cag @@ -0,0 +1,52 @@ +------------------------------------------------------------------------- +-- Imports of Ruler module +------------------------------------------------------------------------- + +%%[1 hs module (AS1.Imports) +%%] + +%%[1 hs export (ImpModMp, as1Imports, as1JoinAGItfs) +%%] + +%%[1 hs import (qualified Data.Map as Map, Common, AbsSyn.AbsSyn1) +%%] + +------------------------------------------------------------------------- +-- Inclusion of split off parts +------------------------------------------------------------------------- + +%%[1 ag import ({AbsSyn/AbsSyn1AG}, {AbsSyn/CommonAG}, {Expr/AbsSynAG}) +%%] + +------------------------------------------------------------------------- +-- Interfacing to AST +------------------------------------------------------------------------- + +%%[1 ag +WRAPPER AGItf +%%] + +%%[1 hs +type ImpModMp = Map.Map Nm SPos + +as1Imports :: AGItf -> ImpModMp +as1Imports r + = (impModMp_Syn_AGItf r2) + where r1 = sem_AGItf r + r2 = wrap_AGItf r1 + (Inh_AGItf ) + +as1JoinAGItfs :: [AGItf] -> AGItf +as1JoinAGItfs ais = AGItf_AGItf $ concat $ [ ds | (AGItf_AGItf ds) <- ais ] +%%] + +------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllDecl AGItf [ | | impModMp USE {`Map.union`} {Map.empty}: {ImpModMp} ] + +SEM Decl + | Include lhs . impModMp = Map.singleton @nm @pos +%%] diff --git a/src/AS1/Misc.cag b/src/AS1/Misc.cag new file mode 100644 --- /dev/null +++ b/src/AS1/Misc.cag @@ -0,0 +1,36 @@ +-- $Id: Ruler.ag 231 2005-06-07 14:39:41Z atze $ + +%%[1 ag + +------------------------------------------------------------------------- +-- Global info +------------------------------------------------------------------------- + +ATTR AllAS1 AGItf [ opts: {Opts} | | ] + +------------------------------------------------------------------------- +-- Unique +------------------------------------------------------------------------- + +ATTR AllAS1 [ | uniq: Int | ] + +SEM AGItf + | AGItf decls . uniq = 0 + +SEM RExpr + | Judge (eqns.uniq,loc.lUniq) = (@lhs.uniq+1,@lhs.uniq) + +------------------------------------------------------------------------- +-- Rule seq nr +------------------------------------------------------------------------- + +ATTR AllDecl [ | rlSeqNr: Int | ] + +SEM Decl + | Rules decls . rlSeqNr = 1 + | Rule lhs . rlSeqNr = @lhs.rlSeqNr + 1 + +SEM AGItf + | AGItf decls . rlSeqNr = 1 + +%%] diff --git a/src/AS1/Pretty.cag b/src/AS1/Pretty.cag new file mode 100644 --- /dev/null +++ b/src/AS1/Pretty.cag @@ -0,0 +1,51 @@ +------------------------------------------------------------------------- +-- Pretty printing of ruler AST1 +------------------------------------------------------------------------- + +%%[1 ag + +ATTR AllAS1 AGItf [ | | pp USE {>-<} {empty} : PP_Doc ] + +SEM AGItf + | AGItf lhs . pp = {- @decls.pp + >-< "---------- dt gam" >-< ppGam @dtGam + >-< -} "---------- dt inv gam" >-< ppGam @dtInvGam + >-< {- "---------- rw gam" >-< ppRwGam @rwGam + >-< "---------- fm gam" >-< ppGam @fmGam + >-< -} "---------- scheme gam" >-< ppGam @scGam + >-< "---------- rule set gam" >-< ppGam @rsGam + >-< "---------- sc dpd graph" >-< pp @scDpdGr + >-< "---------- vw dpd graph" >-< pp @vwDpdGr + +SEM Decl + | Scheme lhs . pp = "scheme" >#< @scKind >#< @nm >-< "=" >#< @decls.pp + | SchemeDeriv lhs . pp = "scheme" >#< @scKind >#< @nm >#< ":" >#< @scDeriv >-< "=" >#< @decls.pp + | Fmt lhs . pp = "format" >#< @fmKind >#< @matchExpr.pp >#< "=" >#< @expr.pp + | ScmView lhs . pp = "view" >#< @nm >-< "=" >#< @decls.pp + | RulView lhs . pp = "view" >#< @nm >-< "=" >#< @jdIntros.pp + | Rules lhs . pp = "rules" >#< @nm >#< "scheme" >#< @schemeNm >-< "=" >#< @decls.pp + | RulesGroup lhs . pp = "rulesgroup" >#< @nm >#< "scheme" >#< @schemeNm >-< "=" >#< (vlist . map (\(rs,r) -> "rule" >#< rs >#< r) $ @rlNms) + | Rule lhs . pp = "rule" >#< @nm >#< "viewsel" >#< pp @viewSel >-< "=" >#< @decls.pp + | ViewHierarchy lhs . pp = "viewhierarchy" >#< text (show @nmOrder) + | ShpJudge lhs . pp = "judgeshape" >#< @expr.pp + | ShpDel lhs . pp = "judgeshape" >#< "-" >#< ppCommas' @fmKinds + | Attr lhs . pp = "holes" >#< @intros.pp + | Explain lhs . pp = "explain" >#< @mbNm >#< "=" >#< ppParens @expr.pp + +SEM RuleJudgeIntro + | PrePost lhs . pp = @pre.pp >-< "---" >-< @post.pp + +SEM RExpr + | Judge lhs . pp = "judge" >#< maybe empty (\n -> pp n >#< "=") @mbRNm >#< pp @schemeNm >#< @eqns.pp + | Del lhs . pp = "judge" >#< "-" >#< ppCommas @nms + +SEM AttrIntro + | Intro lhs . pp = pp @props >#< pp @nm >#< ":" >#< pp @ty + +SEM AttrEqn + | Eqn lhs . pp = "|" >#< pp @nm >#< "=" >#< @expr.pp + +SEM AttrIntroDecl + | Attrs lhs . pp = "inh" >#< @inhs.pp >-< "i+s" >#< @inhsyns.pp >-< "syn" >#< @syns.pp + +%%] diff --git a/src/AS1/RlSel.cag b/src/AS1/RlSel.cag new file mode 100644 --- /dev/null +++ b/src/AS1/RlSel.cag @@ -0,0 +1,14 @@ +------------------------------------------------------------------------- +-- Query function to be used +------------------------------------------------------------------------- + +%%[1 ag + +ATTR AllDecl [ rlSelIsSel: RlSelIsSel | | ] + +SEM AGItf + | AGItf loc . rlSelIsSel = case optMbRlSel @lhs.opts of + Just rs -> rlSelIsSel @vwDpdGr rs + _ -> \_ _ _ -> True + +%%] diff --git a/src/AS1/SchemeDpd.cag b/src/AS1/SchemeDpd.cag new file mode 100644 --- /dev/null +++ b/src/AS1/SchemeDpd.cag @@ -0,0 +1,34 @@ +------------------------------------------------------------------------- +-- Scheme dpds +------------------------------------------------------------------------- + +%%[1 ag + +ATTR AllDecl AllAttrIntroDecl [ | | gathScDpds USE {++} {[]}: {[(Nm,Nm)]} ] + +SEM AttrIntroDecl + | Scheme lhs . gathScDpds = [(@lhs.scmNm,@nm)] + +{- +SEM Decl + | Scheme lhs . gathScDpds = [(@nm,@nm)] ++ @decls.gathScDpds +-} + +------------------------------------------------------------------------- +-- Scheme dpd graph +------------------------------------------------------------------------- + +ATTR AllDecl [ scDpdGr: {DpdGr Nm} | | ] + +SEM AGItf + | AGItf loc . scDpdGr = let missing = gamKeys @decls.gathScGam \\ map fst @decls.gathScDpds + in mkDpdGrFromAssocWithMissing missing @decls.gathScDpds + +------------------------------------------------------------------------- +-- Error checks for mutual dependencies +------------------------------------------------------------------------- + +SEM AGItf + | AGItf loc . errMutSc = dgCheckSCCMutuals (Err_MutDpds emptySPos "toplevel" "scheme") @scDpdGr + +%%] diff --git a/src/AS1/ViewDpd.cag b/src/AS1/ViewDpd.cag new file mode 100644 --- /dev/null +++ b/src/AS1/ViewDpd.cag @@ -0,0 +1,36 @@ +------------------------------------------------------------------------- +-- All used views +------------------------------------------------------------------------- + +%%[1 ag + +ATTR AllDecl [ | | allVwNmS USE {`Set.union`} {Set.empty}: {Set.Set Nm} ] + +SEM Decl + | RulView ScmView DataASTView + lhs . allVwNmS = Set.singleton @nm + +------------------------------------------------------------------------- +-- View order +------------------------------------------------------------------------- + +ATTR AllDecl [ | | gathVwOrder USE {++} {[]}: {[[[Nm]]]} ] + +SEM Decl + | ViewHierarchy lhs . gathVwOrder = [@nmOrder] + +------------------------------------------------------------------------- +-- View dpd graph +------------------------------------------------------------------------- + +ATTR AllDecl [ vwDpdGr: {DpdGr Nm} | | ] + +SEM AGItf + | AGItf loc . vwDpdGr = let vwOrderL = concat @decls.gathVwOrder + missing = @decls.allVwNmS `Set.difference` Set.fromList (concat vwOrderL) + in mkDpdGrFromOrderWithMissing (Set.toList missing) vwOrderL + +SEM Decl + | SchemeDeriv loc . firstVwNm = last (dgTopSort @lhs.vwDpdGr) + +%%] diff --git a/src/AS2/Opts.cag b/src/AS2/Opts.cag new file mode 100644 --- /dev/null +++ b/src/AS2/Opts.cag @@ -0,0 +1,7 @@ +------------------------------------------------------------------------- +-- Global info +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllAS2 AGItf [ opts: {Opts} | | ] +%%] diff --git a/src/AS2/Pretty.cag b/src/AS2/Pretty.cag new file mode 100644 --- /dev/null +++ b/src/AS2/Pretty.cag @@ -0,0 +1,217 @@ +------------------------------------------------------------------------- +-- Pretty printing of ruler AST2 +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllAS2 AGItf [ | | pp USE {>-<} {empty} : PP_Doc ] + +SEM Decls + | Cons lhs . pp = @hd.pp >-< "" >-< @tl.pp + +SEM RlDecls + | Cons lhs . pp = @hd.pp >-< "" >-< @tl.pp +%%] + +------------------------------------------------------------------------- +-- Configuration +------------------------------------------------------------------------- + +%%[1 hs +data PPCfg + = PPCfg + { pcDef :: Nm + , pcUse :: Nm + , pcFigEnv :: Nm + , pcRule :: Nm + } + +mkPPCfg :: Opts -> FmGam Expr -> PPCfg +mkPPCfg o g + = PPCfg + { pcDef = c "rulerCmdDef" + , pcUse = c "rulerCmdUse" + , pcFigEnv = c "rulerRulesetFigureEnv" + , pcRule = c "rulerRuleCmd" + } + where c = fmNmFmtCmd o g . Nm +%%] + +%%[1 ag +ATTR AllAS2 [ ppCfg: PPCfg | | ] + +SEM AGItf + | AGItf decls . ppCfg = mkPPCfg @lhs.opts @lhs.fmGam +%%] + +------------------------------------------------------------------------- +-- Chunks +------------------------------------------------------------------------- + +%%[1 ag +SEM RlDecl + | Chunk lhs . pp = ppWrapShuffle @nm @rl.pp + +SEM Decl + | Chunk lhs . pp = ppWrapShuffle @nm @decl.pp +%%] + +------------------------------------------------------------------------- +-- General: ruleset +------------------------------------------------------------------------- + +%%[1 ag +SEM RlDecl + | Rl lhs . pp = @nm >#< ppBracketsCommas [pp @pos,pp @agStr] + >-< indent 2 (@preJds.pp >-< "---" >-< @postJds.pp) + +SEM Jd + | Ats lhs . pp = @nm >#< ppParens (pp @scNm) >|< ":" >#< @ats.pp + +SEM JdAt + | At lhs . pp = @nm >#< "=" >#< @expr.pp +%%] + +------------------------------------------------------------------------- +-- AG specific: ATTR decls +------------------------------------------------------------------------- + +%%[1 ag +SEM AttrAGDecl + | Attr lhs . pp = let mka g = ppListSep "" "" " " [ n >|< ":" >#< t | (n,t) <- g ] + in "ATTR" >#< @ndNm + >#< ppBrackets (mka @inhAts >#< "|" >#< mka @inhsynAts >#< "|" >#< mka @synAts) +%%] + +------------------------------------------------------------------------- +-- AG/HS specific: DATA decls +------------------------------------------------------------------------- + +%%[1 ag +SEM DataAGDecl + | Data lhs . pp = case optGenFM @lhs.opts of + FmAG -> "DATA" >#< @nmStr >-< indent 2 @alts.pp + FmHS -> "data" >#< @nmStr >-< indent 2 @alts.ppHS + _ -> empty + +SEM DataAGAlt + | Alt lhs . pp = "|" >#< strPad @nmStr @lhs.mxAltWd >|< @flds.pp + +SEM DataAGFld + | Fld lhs . pp = strPad @nmStr @lhs.mxFldWd >|< ":" >#< (if @tyIsData then id else ppCurlys) (pp @ty) + +ATTR AllDtAlt AllDtFld [ mxFldWd: Int | | gathMxFldWd USE {`max`} {0} : Int ] +ATTR AllDtAlt [ mxAltWd: Int | | gathMxAltWd USE {`max`} {0} : Int ] + +SEM DataAGDecl + | Data alts . mxAltWd = @alts.gathMxAltWd + atLhs2texDist + . mxFldWd = @alts.gathMxFldWd + atLhs2texDist + +SEM DataAGDecl + | Data loc . nmStr = show @ndNm + +SEM DataAGAlt + | Alt loc . nmStr = @lhs.mkAltStr $ show $ @nm + lhs . gathMxAltWd = length @nmStr + +SEM DataAGFld + | Fld loc . nmStr = @lhs.mkFldStr $ show $ @nm + lhs . gathMxFldWd = length @nmStr + +ATTR AllDtAlt [ mkAltStr: {String -> String} | | ] +ATTR AllDtFld [ mkFldStr: {String -> String} | | ] + +SEM DataAGDecl + | Data loc . mkAltStr = case optGenFM @lhs.opts of + FmAG -> id + FmHS -> \n -> @nmStr ++ "_" ++ n + +SEM DataAGAlt + | Alt loc . mkFldStr = case optGenFM @lhs.opts of + FmAG -> id + FmHS -> \n -> n ++ "_" ++ @nmStr +%%] + +------------------------------------------------------------------------- +-- HS specific: DATA decls, building on AG info +------------------------------------------------------------------------- + +%%[1 ag +SEM DataAGAlt + | Alt lhs . ppHS = (if @lhs.isFirstAlt then "=" else "|") >#< strPad @nmStr @lhs.mxAltWd >|< (@flds.ppHS >-< "}") + +SEM DataAGFld + | Fld lhs . ppHS = (if @lhs.isFirstFld then "{" else ",") >#< strPad @nmStr @lhs.mxFldWd >|< "::" >#< pp @ty + +ATTR AllDtAlt AllDtFld [ | | ppHS USE {>-<} {empty}: PP_Doc ] +ATTR AllDtAlt [ isFirstAlt: Bool | | ] +ATTR AllDtFld [ isFirstFld: Bool | | ] + +SEM DataAGDecl + | Data alts . isFirstAlt = True + +SEM DataAGAlts + | Cons tl . isFirstAlt = False + +SEM DataAGAlt + | Alt flds . isFirstFld = True + +SEM DataAGFlds + | Cons tl . isFirstFld = False +%%] + +------------------------------------------------------------------------- +-- LaTeX specific: ruleset +------------------------------------------------------------------------- + +%%[1 ag +SEM RlDecl + | LTX lhs . pp = let r = "\\" >|< (pcRule @lhs.ppCfg) >|< ppCurly @rlNm >|< ppCurly @vwNm + >-< ppListSepVV "{%" "}" "\\\\" @preJds.ppL + >-< ppListSepVV "{%" "}" "\\\\" @postJds.ppL + in mkTexCmdDef (pcDef @lhs.ppCfg) @nm r + | LTXAlias lhs . pp = mkTexCmdDef (pcDef @lhs.ppCfg) @fullAliasNm (mkTexCmdUse (pcUse @lhs.ppCfg) @fullNm) + +SEM VwDecl + | LTX lhs . pp = let meta = ensureTeXMath $ switchLaTeXLhs $ exprFmtTeX @lhs.opts @lhs.fmGam @scmExpr.self + in mkTexCmdDef (pcDef @lhs.ppCfg) @scMetaNm meta >-< @rlDecls.pp + | LTXFig lhs . pp = let fig = "\\begin" >|< ppCurly (pcFigEnv @lhs.ppCfg) >|< ppCurly (mkTexCmdUse (pcUse @lhs.ppCfg) @scMetaNm) >|< ppCurly (pp @descr) >|< ppCurly @fullNm >|< (ppCurly @nm) + >-< vlist (intersperse (pp "\\hspace{1ex}") . map (mkTexCmdUse (pcUse @lhs.ppCfg)) $ @rlFullNmL) + >-< "\\end" >|< ppCurly (pcFigEnv @lhs.ppCfg) + in mkTexCmdDef (pcDef @lhs.ppCfg) @fullNm fig + +SEM Jd + | LTX lhs . pp = switchLaTeXLhs (exprFmtTeX @lhs.opts @lhs.fmGam @expr.self) + +ATTR Jds [ | | ppL: {[PP_Doc]} ] + +SEM Jds + | Nil lhs . ppL = [] + | Cons lhs . ppL = if @hd.isSmall && not (null @tl.ppL) + then (@hd.pp >#< "\\hspace{2ex}" >#< head @tl.ppL) : (tail @tl.ppL) + else @hd.pp : @tl.ppL + +ATTR Jd [ | | isSmall : Bool ] +SEM Jd + | Expr LTX lhs.isSmall = @isSmall + | Ats lhs.isSmall = False + +%%] + +------------------------------------------------------------------------- +-- Preamble +------------------------------------------------------------------------- + +%%[1 ag +SEM Decl + | Preamble lhs . pp = pp @preamble +%%] + +------------------------------------------------------------------------- +-- Explain +------------------------------------------------------------------------- + +%%[1 ag +SEM Decl + | ScVwExplain lhs . pp = exprFmtTeX @lhs.opts @lhs.fmGam @exExpr + | ScVwAtExplain lhs . pp = vlist $ map (\(n,e) -> exprFmtTeX @lhs.opts @lhs.fmGam n >#< "&" >#< exprFmtTeX @lhs.opts @lhs.fmGam e >#< "\\\\") $ @atExprs +%%] diff --git a/src/AbsSyn/AbsSyn1.cag b/src/AbsSyn/AbsSyn1.cag new file mode 100644 --- /dev/null +++ b/src/AbsSyn/AbsSyn1.cag @@ -0,0 +1,24 @@ +------------------------------------------------------------------------- +-- Haskell interface to Ruler AST pass 1 +------------------------------------------------------------------------- + +%%[1 hs module (AbsSyn.AbsSyn1) +%%] + +%%[1 hs export(module Expr.Expr, module Ty.Ty, module ViewSel.ViewSel, module Admin) +%%] + +%%[1 hs export(AGItf(..), Decl(..), Decls, AttrIntro(..), AttrIntros, FldIntro(..), FldIntros) +%%] + +%%[1 hs export(AttrIntroDecl(..), AttrIntroDecls, AttrRename(..), AttrRenames, RuleJudgeIntro(..), RuleJudgeIntros) +%%] + +%%[1 hs export(RExpr(..), RExprs, RExprEqn(..), AttrEqn(..), AttrEqns) +%%] + +%%[1 hs import (Common, Expr.Expr, Ty.Ty, ViewSel.ViewSel, Admin( BldRename(..) )) +%%] + +%%[1 ag import({AbsSyn/AbsSyn1AG}, {AbsSyn/CommonAG}) +%%] diff --git a/src/AbsSyn/AbsSyn1AG.cag b/src/AbsSyn/AbsSyn1AG.cag new file mode 100644 --- /dev/null +++ b/src/AbsSyn/AbsSyn1AG.cag @@ -0,0 +1,184 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- Ruler AST, pass 1 +------------------------------------------------------------------------- + +------------------------------------------------------------------------- +-- Declarations +------------------------------------------------------------------------- + +DATA Decl + | Preamble fmKind : {FmKind} + preamble : {String} + | Extern nms : {[Nm]} + | Include pos : {SPos} + nm : {Nm} + | Scheme pos : {SPos} + scKind : {ScKind} + nm : {Nm} + mbAGNm : {Maybe String} + decls : Decls + | SchemeDeriv pos : {SPos} + scKind : {ScKind} + nm : {Nm} + scDeriv : {ScDeriv} + mbAGNm : {Maybe String} + decls : Decls + | Fmt fmKind : {FmKind} + atIO : {AtDir} + matchExpr : Expr + expr : Expr + | Rules pos : {SPos} + nm : {Nm} + schemeNm : {Nm} + viewSel : ViewSel + info : {String} + decls : Decls + | RulesGroup pos : {SPos} + nm : {Nm} + schemeNm : {Nm} + viewSel : ViewSel + info : {String} + rlNms : {[(Nm,Nm)]} + | Rule pos : {SPos} + nm : {Nm} + mbBasedOnNm : {Maybe Nm} + viewSel : {Maybe ViewSel} + mbAGNm : {Maybe String} + decls : Decls + | RulView pos : {SPos} + nm : {Nm} + jdIntros : RuleJudgeIntros + group : {[[Nm]]} + | ShpJudge pos : {SPos} + fmKind : {FmKind} + expr : Expr + | ShpDel pos : {SPos} + fmKinds : {[FmKind]} + | ScmView nm : {Nm} + decls : Decls + | ViewHierarchy nmOrder : {[[Nm]]} + | Attr intros : AttrIntroDecls + | Explain mbNm : {Maybe Nm} + expr : Expr + | DataAST pos : {SPos} + nm : Nm + schemeNms : {[Nm]} + decls : Decls + | DataASTView pos : {SPos} + nm : Nm + decls : Decls + | DataASTAlt pos : {SPos} + nm : Nm + ruleNm : Nm + mbBasedOnNm : {Maybe Nm} + fldIntros : FldIntros + +TYPE Decls = [Decl] + +SET AllDecl = Decl Decls + +------------------------------------------------------------------------- +-- Data/AST decl +------------------------------------------------------------------------- + +DATA FldIntro + | Intro nm : {Nm} + ty : Ty + +TYPE FldIntros = [FldIntro] + +SET AllFldIntro = FldIntros FldIntro + +------------------------------------------------------------------------- +-- Attr intro decl +------------------------------------------------------------------------- + +DATA AttrIntroDecl + | Attrs inhs : AttrIntros + inhsyns : AttrIntros + syns : AttrIntros + | AttrsProp intros : AttrIntros + | Scheme pos : {SPos} + nm : {Nm} + renames : AttrRenames + +TYPE AttrIntroDecls = [AttrIntroDecl] + +DATA AttrRename + | Rename pos : {SPos} + nmNew : {Nm} + nmOld : {Nm} + | EqualTo pos : {SPos} + nmLeft : {Nm} + nmRight : {Nm} + +TYPE AttrRenames = [AttrRename] + +DATA AttrIntro + | Intro props : {[AtProp]} + nm : {Nm} + ty : {Nm} + +TYPE AttrIntros = [AttrIntro] + +SET AllAttrIntro = AttrIntro AttrIntros +SET AllAttrRename = AttrRename AttrRenames +SET AllAttrIntroDecl = AllAttrIntro AllAttrRename AttrIntroDecl AttrIntroDecls + +------------------------------------------------------------------------- +-- Rule judgement intro +------------------------------------------------------------------------- + +DATA RuleJudgeIntro + | PrePost extNms : {[Nm]} + pre : RExprs + post : RExprs + | RulesetRule pos : {SPos} + rsNm : {Nm} + rlNm : {Nm} + schemeRnmL : {[BldRename]} + +TYPE RuleJudgeIntros = [RuleJudgeIntro] + +SET AllRuleJudgeIntro = RuleJudgeIntros RuleJudgeIntro +SET AllRuleJudgeIntroDecl = AllRuleJudgeIntro + +------------------------------------------------------------------------- +-- Rule expr's +------------------------------------------------------------------------- + +DATA RExpr + | Judge pos : {SPos} + mbRNm : {Maybe Nm} + schemeNm : {Nm} + eqns : RExprEqn + isSmallExpr : {Bool} + | Del pos : {SPos} + nms : {[Nm]} + +DATA RExprEqn + | Attrs eqns : AttrEqns + | Expr expr : Expr + +TYPE RExprs = [RExpr] + +SET AllRExpr = RExpr RExprs + +DATA AttrEqn + | Eqn nm : {Nm} + expr : Expr + | Del nm : {Nm} + +TYPE AttrEqns = [AttrEqn] + +SET AllAttrEqn = RExprEqn AttrEqn AttrEqns + +------------------------------------------------------------------------- +-- Sets of AST data's +------------------------------------------------------------------------- + +SET AllAS1 = AllRExpr AllAttrEqn AllAttrIntroDecl AllRuleJudgeIntroDecl AllFldIntro AllDecl + +%%] diff --git a/src/AbsSyn/AbsSyn2.cag b/src/AbsSyn/AbsSyn2.cag new file mode 100644 --- /dev/null +++ b/src/AbsSyn/AbsSyn2.cag @@ -0,0 +1,33 @@ +------------------------------------------------------------------------- +-- Haskell interface to Ruler AST pass 2 +------------------------------------------------------------------------- + +%%[1 hs module (AbsSyn.AbsSyn2) +%%] + +%%[1 hs export (module Expr.Expr, module Ty.Ty, module ARule.ARule, module ViewSel.ViewSel) +%%] + +%%[1 hs export (AGItf(..), Decl(..), Decls, RsVwDecl(..), RsVwDecls, AttrAGDecl(..), DataAGDecl(..), DataAGAlt(..), DataAGAlts) +%%] + +%%[1 hs export (DataAGFld(..), DataAGFlds, VwDecl(..), VwDecls, RlDecl(..), RlDecls, Jd(..), Jds, JdAt(..), JdAts, wrapInChunk) +%%] + +%%[1 hs import (qualified Data.Set as Set, Opts, Common, Expr.Expr, Ty.Ty, ARule.ARule, ViewSel.ViewSel) +%%] + +%%[1 ag import ({AbsSyn/AbsSyn2AG}, {AbsSyn/CommonAG}) +%%] + +------------------------------------------------------------------------- +-- Optional wrap in chunk +------------------------------------------------------------------------- + +%%[1 hs +wrapInChunk :: (Nm -> a->a) -> Opts -> Nm -> a -> a +wrapInChunk mk opts n + = if optFragWrap opts + then mk n + else id +%%] diff --git a/src/AbsSyn/AbsSyn2AG.cag b/src/AbsSyn/AbsSyn2AG.cag new file mode 100644 --- /dev/null +++ b/src/AbsSyn/AbsSyn2AG.cag @@ -0,0 +1,147 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- Ruler AST, pass 2 +------------------------------------------------------------------------- + +------------------------------------------------------------------------- +-- Declarations +------------------------------------------------------------------------- + +DATA Decl + | Preamble preamble : {String} + | ScVwExplain exExpr : {Expr} + | ScVwAtExplain atExprs : {[(Expr,Expr)]} + | RsVw decl : RsVwDecl + | AttrAG decl : AttrAGDecl + | DataAG decl : DataAGDecl + | Chunk nm : {Nm} + decl : Decl + +TYPE Decls = [Decl] + +SET AllDc = Decl Decls + +DATA RsVwDecl + | Rs nm : {Nm} + scNm : {Nm} + descr : {String} + vwDecls : VwDecls + +TYPE RsVwDecls = [RsVwDecl] + +SET AllRs = RsVwDecl RsVwDecls + +DATA AttrAGDecl + | Attr ndNm : {Nm} + inhAts : {[(Nm,Nm)]} + inhsynAts : {[(Nm,Nm)]} + synAts : {[(Nm,Nm)]} + +SET AllAtAG = AttrAGDecl + +DATA DataAGDecl + | Data ndNm : {Nm} + alts : DataAGAlts + +DATA DataAGAlt + | Alt nm : {Nm} + flds : DataAGFlds + +TYPE DataAGAlts = [DataAGAlt] + +DATA DataAGFld + | Fld nm : {Nm} + ty : {Ty} + tyIsData : {Bool} + +TYPE DataAGFlds = [DataAGFld] + +SET AllDtFld = DataAGFlds DataAGFld +SET AllDtAlt = DataAGAlts DataAGAlt +SET AllDtAG = DataAGDecl AllDtAlt AllDtFld + +DATA VwDecl + | Vw nm : {Nm} + fullNm : {Nm} + rlDecls : RlDecls + | Grp nm : {Nm} + fullNm : {Nm} + rlFullNmL : {[(Nm,Nm)]} + | LTX nm : {Nm} + scMetaNm : {Nm} + scmExpr : Expr + rlDecls : RlDecls + | LTXFig nm : {Nm} + fullNm : {Nm} + scMetaNm : {Nm} + descr : {String} + rlFullNmL : {[Nm]} + +TYPE VwDecls = [VwDecl] + +SET AllVw = VwDecl VwDecls + +DATA RlDecl + | Rl nm : {Nm} + fullNm : {Nm} + pos : {SPos} + agStr : Nm + preJds : Jds + postJds : Jds + | LTX nm : {Nm} + rlNm : {Nm} + vwNm : {Nm} + pos : {SPos} + preJds : Jds + postJds : Jds + | LTXAlias fullAliasNm : {Nm} + fullNm : {Nm} + | AG nm : {Nm} + pos : {SPos} + arule : ARule + | Chunk nm : {Nm} + rl : RlDecl + +TYPE RlDecls = [RlDecl] + +SET AllRl = RlDecl RlDecls + +DATA Jd + | Ats nm : {Nm} + scNm : {Nm} + ats : JdAts + | Expr nm : {Nm} + scNm : {Nm} + expr : Expr + isSmall : {Bool} + | LTX nm : {Nm} + scNm : {Nm} + expr : Expr + isSmall : {Bool} + +TYPE Jds = [Jd] + +SET AllJd = Jd Jds + +DATA JdAt + | At nm : {Nm} + expr : Expr + +TYPE JdAts = [JdAt] + +SET AllAt = JdAt JdAts + +SET AllDecl + = AllDc AllRs AllVw + AllRl AllJd AllAt + AllAtAG + AllDtAG + +------------------------------------------------------------------------- +-- Sets of AST data's +------------------------------------------------------------------------- + +SET AllAS2 = AllDecl + +%%] diff --git a/src/AbsSyn/CommonAG.cag b/src/AbsSyn/CommonAG.cag new file mode 100644 --- /dev/null +++ b/src/AbsSyn/CommonAG.cag @@ -0,0 +1,12 @@ +------------------------------------------------------------------------- +-- Ruler AST, common between passes +------------------------------------------------------------------------- + +------------------------------------------------------------------------- +-- Interfacing +------------------------------------------------------------------------- + +%%[1 ag +DATA AGItf + | AGItf decls : Decls +%%] diff --git a/src/Admin.chs b/src/Admin.chs new file mode 100644 --- /dev/null +++ b/src/Admin.chs @@ -0,0 +1,835 @@ +%%[1 hs module (Admin) +%%] + +%%[1 hs export (module FmGam, module JdShpGam) +%%] + +%%[1 hs export (DtFldInfo(..), DtFldGam, emptyDtFldInfo, DtAltInfo(..), DtAltGam, emptyDtAltInfo, DtVwInfo(..), DtVwGam, emptyDtVwInfo) +%%] + +%%[1 hs export (DtInfo(..), DtGam, emptyDtInfo, dtGamInv, dtVwGamLookup, DtAltInvInfo(..), DtAltInvGam, emptyDtAltInvInfo, DtVwInvInfo(..), DtVwInvGam) +%%] + +%%[1 hs export (DtInvInfo(..), DtInvGam, dtVwRlInvGamLookup, dtInvGamRlMbOn, dtInvGamRlVwS, AtInfo(..), AtGam, emptyAtInfo, atGamNode) +%%] + +%%[1 hs export (atMbSynInh, atHasDir, atFilterProps, atHasProp, atHasProps, atIsExternUndef, AtDefUse(..), atDefUse, BldRename(..)) +%%] + +%%[1 hs export (ScAtBld(..), emptyScAtBld, sabFilterScheme, ScAtBldRename(..), sabrGamRename, ExplInfo(..), ExplGam) +%%] + +%%[1 hs export (VwScInfo(..), VwScGam, emptyVwScInfo, vwscAtGam, ScInfo(..), ScGam, emptyScInfo, scVwGamLookup, scVwGamNodeAt) +%%] + +%%[1 hs export (JAInfo(..), JAGam, mkJAInfo, jaGamToFmGam, fmGamToJaGam) +%%] + +%%[1 hs export (REInfo(..), REGam, reMbJAGam, reMbJd, reUpdJAGam, reGamUnionShadow, reGamFilterOutDel, reGamJAGamDifference, reGamJAGamDifferenceOnExpr) +%%] + +%%[1 hs export (RlChInfo(..), RlChGam, rcGamUnionShadow, RlJdBld(..), VwRlInfo(..), VwRlGam, emptyVwRlInfo, mkVwRlInfo) +%%] + +%%[1 hs export (vwrlPreGam, vwrlPostGam, vwrlExtNmS, vwrlDelEmptyJd, vrwlIsEmpty, vwrlScc, vwrlUndefs) +%%] + +%%[1 hs export (RlInfo(..), RlGam, emptyRlInfo, rlVwGamLookup, rlVwRlOnL) +%%] + +%%[1 hs export (RsInfo(..), RsGam, emptyRsInfo, rsInfoIsPlain, rsInfoIsGroup, rsRlVwGamLookup, rsRlOrder, rsInfoMbRlGam) +%%] + +%%[1 hs import (Data.Maybe, Data.Char, Data.List, qualified Data.Set as Set, qualified Data.Map as Map) +%%] + +%%[1 hs import (UHC.Util.Utils, UHC.Util.Pretty, Common, Gam, FmGam, JdShpGam) +%%] + +%%[1 hs import (Expr.Utils, Ty.Utils) +%%] + + +%%[1 hs + +------------------------------------------------------------------------- +-- Data/AST: field +------------------------------------------------------------------------- + +data DtFldInfo + = DtFldInfo + { dfNm :: Nm + , dfTy :: Ty + , dfSeqNr :: Int + } + +emptyDtFldInfo :: DtFldInfo +emptyDtFldInfo = DtFldInfo nmUnk tyUnk 0 + +instance Show DtFldInfo where + show _ = "DtFldInfo" + +instance PP DtFldInfo where + pp i = "DtFld" >#< pp (dfNm i) >|< "/" >|< pp (dfSeqNr i) >#< "::" >#< pp (dfTy i) + +type DtFldGam = Gam Nm DtFldInfo + +------------------------------------------------------------------------- +-- Data/AST: alternative +------------------------------------------------------------------------- + +data DtAltInfo + = DtAltInfo + { daNm :: Nm + , daRlNm :: Nm + , daMbOnNm :: Maybe Nm + , daFldGam :: DtFldGam + } + +emptyDtAltInfo :: DtAltInfo +emptyDtAltInfo = DtAltInfo nmUnk nmUnk Nothing emptyGam + +instance Show DtAltInfo where + show _ = "DtAltInfo" + +instance PP DtAltInfo where + pp i = "DtAlt" >#< pp (daRlNm i) >#< ppGam (daFldGam i) + +type DtAltGam = Gam Nm DtAltInfo + +------------------------------------------------------------------------- +-- Data/AST: view +------------------------------------------------------------------------- + +data DtVwInfo + = DtVwInfo + { vdNm :: Nm + , vdAltGam :: DtAltGam + , vdFullAltGam :: DtAltGam + } + +emptyDtVwInfo :: DtVwInfo +emptyDtVwInfo = DtVwInfo nmUnk emptyGam emptyGam + +instance Show DtVwInfo where + show _ = "DtVwInfo" + +instance PP DtVwInfo where + pp i = "VwDt" >#< pp (vdNm i) >#< (ppGam (vdAltGam i) >-< ppGam (vdFullAltGam i)) + +type DtVwGam = Gam Nm DtVwInfo + +------------------------------------------------------------------------- +-- Data/AST: data +------------------------------------------------------------------------- + +data DtInfo + = DtInfo + { dtNm :: Nm + , dtScNmL :: [Nm] + , dtVwGam :: DtVwGam + } + +emptyDtInfo :: DtInfo +emptyDtInfo = DtInfo nmUnk [] emptyGam + +instance Show DtInfo where + show _ = "DtInfo" + +instance PP DtInfo where + pp i = "Dt" >#< ppCommas' (dtScNmL i) >#< ppGam (dtVwGam i) + +type DtGam = Gam Nm DtInfo + +dtGamInv :: DtGam -> DtInvGam +dtGamInv dtGam + = gamFoldWithKey + (\dn di dg + -> let vg + = gamFoldWithKey + (\vn vi vg + -> let ag + = gamFoldWithKey + (\an ai ag + -> let cg = gamMap dfSeqNr $ gamFilter (\i -> tyTopNm (dfTy i) `gamMember` dtGam) $ daFldGam ai + in gamInsertShadow (daRlNm ai) (DtAltInvInfo (daRlNm ai) an (daMbOnNm ai) cg) ag + ) + emptyGam + (vdFullAltGam vi) + in gamInsertShadow vn (DtVwInvInfo vn ag) vg + ) + emptyGam + (dtVwGam di) + in foldr (\n -> gamInsertShadow n (DtInvInfo n dn vg)) dg (dtScNmL di) + ) + emptyGam + dtGam + +dtVwGamLookup :: Nm -> Nm -> DtGam -> Maybe (DtInfo,DtVwInfo) +dtVwGamLookup = dblGamLookup dtVwGam + +------------------------------------------------------------------------- +-- Data/AST: alternative (inverse) +------------------------------------------------------------------------- + +data DtAltInvInfo + = DtAltInvInfo + { daiNm :: Nm + , daiAGNm :: Nm + , daiMbOnNm :: Maybe Nm + , daiChOrdGam :: ChOrdGam + } + +emptyDtAltInvInfo :: DtAltInvInfo +emptyDtAltInvInfo = DtAltInvInfo nmUnk nmUnk Nothing emptyGam + +instance Show DtAltInvInfo where + show _ = "DtAltInvInfo" + +instance PP DtAltInvInfo where + pp i = "DtAltInv" >#< pp (daiAGNm i) >#< pp (daiMbOnNm i) >#< ppGam (daiChOrdGam i) + +type DtAltInvGam = Gam Nm DtAltInvInfo + +------------------------------------------------------------------------- +-- Data/AST: view (inverse) +------------------------------------------------------------------------- + +data DtVwInvInfo + = DtVwInvInfo + { vdiNm :: Nm + , vdiFullAltGam :: DtAltInvGam + } + +emptyDtVwInvInfo :: DtVwInvInfo +emptyDtVwInvInfo = DtVwInvInfo nmUnk emptyGam + +instance Show DtVwInvInfo where + show _ = "DtVwInvInfo" + +instance PP DtVwInvInfo where + pp i = "VwDtInv" >#< ppGam (vdiFullAltGam i) + +type DtVwInvGam = Gam Nm DtVwInvInfo + +------------------------------------------------------------------------- +-- Data/AST: data (inverse) +------------------------------------------------------------------------- + +data DtInvInfo + = DtInvInfo + { dtiNm :: Nm + , dtiAGNm :: Nm + , dtiVwGam :: DtVwInvGam + } + +emptyDtInvInfo :: DtInvInfo +emptyDtInvInfo = DtInvInfo nmUnk nmUnk emptyGam + +instance Show DtInvInfo where + show _ = "DtInvInfo" + +instance PP DtInvInfo where + pp i = "DtInv" >#< pp (dtiAGNm i) >#< ppGam (dtiVwGam i) + +type DtInvGam = Gam Nm DtInvInfo + +dtVwRlInvGamLookup :: Nm -> Nm -> Nm -> DtInvGam -> Maybe (DtInvInfo,DtVwInvInfo,DtAltInvInfo) +dtVwRlInvGamLookup = tripleGamLookup dtiVwGam vdiFullAltGam + +dtInvGamRlMbOn :: DtInvGam -> RlInfo e -> Nm -> Nm -> Maybe Nm +dtInvGamRlMbOn dg rlInfo scNm vwNm + = case rlMbOnNm rlInfo of + Just n -> Just n + Nothing -> case dtVwRlInvGamLookup scNm vwNm (rlNm rlInfo) dg of + Just (_,_,i) -> daiMbOnNm i + Nothing -> Nothing + +dtInvGamRlVwS :: Nm -> Nm -> DtInvGam -> Maybe (Set.Set Nm) +dtInvGamRlVwS scNm rlNm g + = case gamLookup scNm g of + Just i + -> Just $ Set.fromList $ [ v | (v,vi) <- gamAssocs $ dtiVwGam i, isJust $ gamLookup rlNm $ vdiFullAltGam vi ] + _ -> Nothing + +------------------------------------------------------------------------- +-- Attr +------------------------------------------------------------------------- + +data AtInfo + = AtInfo + { atNm :: Nm + , atDirs :: [AtDir] + , atProps :: [AtProp] + , atTy :: Nm + } + +emptyAtInfo :: AtInfo +emptyAtInfo = AtInfo nmUnk [] [] nmUnk + +instance Show AtInfo where + show _ = "AtInfo" + +instance PP AtInfo where + pp i = "AT" >#< pp (atTy i) >#< pp (show (atDirs i)) >#< pp (show (atProps i)) + +type AtGam = Gam Nm AtInfo + +atGamNode :: AtGam -> Maybe Nm +atGamNode g + = do let aNdGm = gamFilter (\ai -> AtNode `atHasProp` ai) g + case gamAssocsShadow aNdGm of + ((na,ai):_) -> return na + _ -> Nothing + +atMbSynInh :: AtInfo -> Maybe Nm +atMbSynInh i + = if AtThread `atHasProp` i then Just (nmInit n) + else if AtUpdown `atHasProp` i then Just (nmInit n) + else if AtInh `atHasDir` i + && AtSyn `atHasDir` i then Just n + else Nothing + where n = atNm i + +atHasProp :: AtProp -> AtInfo -> Bool +atHasProp p i = p `elem` atProps i + +atFilterProps :: [AtProp] -> AtInfo -> [AtProp] +atFilterProps ps i = ps `intersect` atProps i + +atHasProps :: [AtProp] -> AtInfo -> Bool +atHasProps ps i = not $ null $ ps `atFilterProps` i + +atHasDir :: AtProp -> AtInfo -> Bool +atHasDir p i = p `elem` atDirs i + +atIsExternUndef :: Bool -> AtInfo -> Bool +atIsExternUndef isPre i + = isExtern && defUse == ADDef + where isExtern = AtExtern `atHasProp` i + defUse = atDefUse isPre i + +------------------------------------------------------------------------- +-- Attr def/use +------------------------------------------------------------------------- + +data AtDefUse + = ADDef | ADUse | ADNode | ADNoDir + deriving (Show,Eq,Ord) + +atDefUse :: Bool -> AtInfo -> AtDefUse +atDefUse isPre atInfo + = if AtNode `atHasProp` atInfo + then ADNode + else if isSyn + then if isPre then ADUse else ADDef + else if isInh + then if isPre then ADDef else ADUse + else ADNoDir + where isSyn = AtSyn `atHasDir` atInfo + isInh = AtInh `atHasDir` atInfo + +------------------------------------------------------------------------- +-- Attr build description based on scheme +------------------------------------------------------------------------- + +data ScAtBldRename + = ScAtBldRename + { sabrNm :: Nm + , sabrNmOther :: Nm + } + | ScAtBldEqualTo + { sabrNm :: Nm + , sabrNmOther :: Nm + } + +instance Show ScAtBldRename where + show _ = "ScAtBldRename" + +instance PP ScAtBldRename where + pp (ScAtBldRename n o) = "SABR" >#< n >#< ":=" >#< o + pp (ScAtBldEqualTo n o) = "SABR" >#< n >#< "=" >#< o + +sabrGamRename :: [ScAtBldRename] -> Gam Nm v -> (Gam Nm v,[Nm]) +sabrGamRename rnL g + = foldl (\(g,nL) r + -> case r of + ScAtBldRename n o + | isJust mbO + -> (gamInsert n (fromJust mbO) $ gamDelete o $ g,nL) + | otherwise + -> (g,o:nL) + where mbO = gamLookup o g + _ -> (g,nL) + ) + (g,[]) rnL + +------------------------------------------------------------------------- +-- Rename of .. during build +------------------------------------------------------------------------- + +data BldRename + = BldRename + { brNmFrom :: Nm + , brNmTo :: Nm + } + +instance Show BldRename where + show _ = "BldRename" + +instance PP BldRename where + pp (BldRename f t) = "BR" >#< f >#< "->" >#< t + + +------------------------------------------------------------------------- +-- Attr build description for scheme +------------------------------------------------------------------------- + +data ScAtBld + = ScAtBldDirect + { sabAtGam :: AtGam + } + | ScAtBldScheme + { sabNm :: Nm + , sabPos :: SPos + , sabRenameL :: [ScAtBldRename] + } + +emptyScAtBld :: ScAtBld +emptyScAtBld = ScAtBldScheme nmUnk emptySPos [] + +sabFilterScheme :: [ScAtBld] -> [ScAtBld] +sabFilterScheme l = [ b | b@(ScAtBldScheme _ _ _) <- l ] + +instance Show ScAtBld where + show _ = "ScAtBld" + +instance PP ScAtBld where + pp (ScAtBldDirect i ) = "SAB-D" >#< pp i + pp i@(ScAtBldScheme _ _ _) = "SAB-S" >#< sabNm i >#< ppBracketsCommas (sabRenameL i) + +------------------------------------------------------------------------- +-- Explanations +------------------------------------------------------------------------- + +data ExplInfo e + = ExplInfo + { explExpr :: e + } + +instance Show (ExplInfo e) where + show _ = "ExplInfo" + +instance PP e => PP (ExplInfo e) where + pp (ExplInfo e) = "Expl" >#< pp e + +type ExplGam e = Gam Nm (ExplInfo e) + +------------------------------------------------------------------------- +-- View (related to scheme) +------------------------------------------------------------------------- + +type AtEqlToMp = Map.Map Nm (Set.Set Nm) + +data VwScInfo e + = VwScInfo + { vwscNm :: Nm + , vwscJdShpGam :: JdShpGam e + , vwscAtBldL :: [ScAtBld] + , vwscFullAtBldL :: [ScAtBld] + , vwscFullAtBldGam :: AtGam + , vwscFullAtGam :: AtGam + , vwscExplGam :: ExplGam e + } + +emptyVwScInfo :: VwScInfo e +emptyVwScInfo = VwScInfo nmNone emptyGam [] [] emptyGam emptyGam emptyGam + +vwscAtGam :: VwScInfo e -> AtGam +vwscAtGam i = gamUnions [ g | (ScAtBldDirect g) <- vwscAtBldL i ] + +instance Show (VwScInfo e) where + show _ = "VwScInfo" + +instance PP e => PP (VwScInfo e) where + pp i = "VWSc" >#< pp (vwscNm i) >#< (ppBracketsCommas (vwscAtBldL i) >-< ppGam (vwscFullAtGam i) >-< ppGam (vwscJdShpGam i) >-< ppGam (vwscExplGam i)) + +type VwScGam e = Gam Nm (VwScInfo e) + +------------------------------------------------------------------------- +-- Scheme +------------------------------------------------------------------------- + +data ScInfo e + = ScInfo + { scPos :: SPos + , scNm :: Nm + , scMbAGStr :: Maybe String + , scKind :: ScKind + , scVwGam :: VwScGam e + } + +emptyScInfo :: ScInfo e +emptyScInfo = ScInfo emptySPos nmNone Nothing ScJudge emptyGam + +instance Show (ScInfo e) where + show _ = "ScInfo" + +instance PP e => PP (ScInfo e) where + pp i = "SC" >#< pp (scNm i) >#< ppGam (scVwGam i) + +type ScGam e = Gam Nm (ScInfo e) + +scVwGamLookup :: Nm -> Nm -> ScGam e -> Maybe (ScInfo e,VwScInfo e) +scVwGamLookup = dblGamLookup scVwGam + +scVwGamNodeAt :: Nm -> Nm -> ScGam e -> Maybe Nm +scVwGamNodeAt nSc nVw g + = do (si,vi) <- scVwGamLookup nSc nVw g + atGamNode (vwscAtGam vi) + +------------------------------------------------------------------------- +-- RExpr's judgement attr equations +------------------------------------------------------------------------- + +data JAInfo e + = JAInfo + { jaNm :: Nm + , jaExpr :: e + , jaNmS :: Set.Set Nm + } + | JAInfoDel + { jaNm :: Nm + } + +mkJAInfo :: Nm -> Expr -> JAInfo Expr +mkJAInfo n e = JAInfo n e (exprNmS e) + +instance Show (JAInfo e) where + show _ = "JAInfo" + +instance PP e => PP (JAInfo e) where + pp i@(JAInfo _ _ _) = "JA" >#< (pp (jaNm i) >|< ":" >#< pp (jaExpr i) >-< pp (show (jaNmS i))) + pp i@(JAInfoDel _) = "JADel" >#< jaNm i + +type JAGam e = Gam Nm (JAInfo e) + +jaGamToFmGam :: (e -> e) -> JAGam e -> FmGam e +jaGamToFmGam f = fmGamFromList . map (\(n,i) -> (n,f (jaExpr i))) . gamAssocsShadow + +fmGamToJaGam :: FmKind -> FmGam Expr -> JAGam Expr +fmGamToJaGam fm = gamFromAssocs . map (\(n,e) -> (n,mkJAInfo n e)) . gamAssocsShadow . gamMap (fkGamLookup (panic "fmGamToJaGam") id [fm] . fmKdGam) + +------------------------------------------------------------------------- +-- RExpr +------------------------------------------------------------------------- + +data REInfo e + = REInfoJudge + { reNm :: Nm + , reScNm :: Nm + , reInNmS, reOutNmS :: Set.Set Nm + , reJAGam :: JAGam e + , reIsSmall :: Bool + } + | REInfoDel + { reNms :: [Nm] + } + +reMbJd :: REInfo e -> Maybe (REInfo e) +reMbJd (REInfoDel _) = Nothing +reMbJd i = Just i + +reNm' :: REInfo e -> Nm +reNm' = maybe nmUnk reNm . reMbJd + +reMbJAGam :: REInfo e -> Maybe (JAGam e) +reMbJAGam = fmap reJAGam . reMbJd + +reUpdJAGam :: JAGam e -> REInfo e -> REInfo e +reUpdJAGam g i = maybe i (\i -> i {reJAGam = g}) $ reMbJd i + +instance Show (REInfo e) where + show _ = "REInfo" + +instance PP e => PP (REInfo e) where + pp (REInfoJudge n sn i o g _) = "REJdg" >#< pp n >#< pp sn >#< (pp (show i) >#< pp (show o) >-< ppGam g) + pp (REInfoDel ns ) = "REDel" >#< ppCommas ns + +type REGam e = Gam Nm (REInfo e) + +reGamUnionShadow :: REGam e -> REGam e -> REGam e +reGamUnionShadow g gamPrev + = gamFoldWithKey + (\n i gamPrev + -> case i of + REInfoJudge _ sn _ _ jg _ + -> gamInsertShadow n (iPrev {reJAGam = jg `gamUnionShadow` jaGamPrev}) gamPrev + where (jaGamPrev,iPrev) + = case gamLookup n gamPrev of + Just iPrev@(REInfoJudge _ snPrev _ _ _ _) | snPrev == sn + -> (reJAGam iPrev,iPrev) + _ -> (emptyGam,i) + REInfoDel ns + -> gamInsert n i $ foldr gamDelete gamPrev ns + ) + gamPrev g + +reGamFilterOutDel :: REGam e -> REGam e +reGamFilterOutDel = gamFilter (\i -> case i of {REInfoDel _ -> False ; _ -> True}) + +reGamFilterOutEmpty :: REGam e -> REGam e +reGamFilterOutEmpty = gamFilter (not . gamIsEmpty . reJAGam) + +{- +reGamJAGamDifference :: REGam e -> REGam e -> REGam e +reGamJAGamDifference g gamDiff + = gamMap (\i -> gamLookupMaybe i (\j -> i {reJAGam = reJAGam i `gamDifference` reJAGam j}) (reNm i) gamDiff) g +-} +reGamJAGamDifference' :: (JAGam e -> JAGam e -> JAGam e) -> REGam e -> REGam e -> REGam e +reGamJAGamDifference' jgFilterOut g gamDiff + = reGamFilterOutEmpty + $ gamMap (\i -> gamLookupMaybe i + (\j -> i {reJAGam = reJAGam i `jgFilterOut` reJAGam j}) + (reNm' i) gamDiff + ) + g + +reGamJAGamDifferenceOnExpr :: Eq e => REGam e -> REGam e -> REGam e +reGamJAGamDifferenceOnExpr + = reGamJAGamDifference' jgFilterOut + where jgFilterOut g gOut = gamFilterWithKey (\n i -> gamLookupMaybe True (\j -> jaExpr i /= jaExpr j) n gOut) g + +reGamJAGamDifference :: REGam e -> REGam e -> REGam e +reGamJAGamDifference + = reGamJAGamDifference' gamDifference + +infixr 5 `reGamUnionShadow` + +------------------------------------------------------------------------- +-- Changed attr's w.r.t. previous view +------------------------------------------------------------------------- + +data RlChInfo + = RlChInfo + { rcJdNm :: Nm + , rcAtNm :: Nm + } + +instance Show RlChInfo where + show _ = "RlChInfo" + +instance PP RlChInfo where + pp i = "RC" >#< pp (rcJdNm i) >#< pp (rcAtNm i) + +type RlChGam = Gam Nm (Gam Nm RlChInfo) + +rcGamUnionShadow :: RlChGam -> RlChGam -> RlChGam +rcGamUnionShadow = gamUnionWith gamUnionShadow + +------------------------------------------------------------------------- +-- Attr build description for rule +------------------------------------------------------------------------- + +data RlJdBld e + = RlJdBldDirect + { rjbExtNmS :: Set.Set Nm + , rjbPreGam :: REGam e + , rjbPostGam :: REGam e + } + | RlJdBldFromRuleset + { rjbPos :: SPos + , rjbRsNm :: Nm + , rjbRlNm :: Nm + , rjbScRenameL :: [BldRename] + } + +instance Show (RlJdBld e) where + show _ = "RlJdBld" + +instance PP e => PP (RlJdBld e) where + pp (RlJdBldDirect _ g1 g2) = "RJB-D" >#< (ppGam g1 >-< ppGam g2) + pp i@(RlJdBldFromRuleset _ _ _ _) = "RJB-RS" >#< rjbRsNm i >#< rjbRlNm i >#< ppBracketsCommas (rjbScRenameL i) + +------------------------------------------------------------------------- +-- View (related to rule) +------------------------------------------------------------------------- + +data VwRlInfo e + = VwRlInfo + { vwrlNm :: Nm + , vwrlPos :: SPos + , vwrlJdBldL :: [RlJdBld e] + , vwrlJdBldOnAL, vwrlJdBldOnBL :: [RlJdBld e] -- for debug + , vwrlFullNoDfltPreGam, vwrlFullNoDfltPostGam :: REGam e + , vwrlFullPreGam, vwrlFullPostGam :: REGam e + , vwrlPreScc :: [[Nm]] + , vwrlMbChGam :: Maybe RlChGam + , vwrlAuxGroups :: [[Nm]] + } + +emptyVwRlInfo :: VwRlInfo e +emptyVwRlInfo = VwRlInfo nmNone emptySPos [] [] [] emptyGam emptyGam emptyGam emptyGam [] Nothing [] + +mkVwRlInfo :: Nm -> SPos -> [RlJdBld e] -> [[Nm]] -> VwRlInfo e +mkVwRlInfo n p b g = emptyVwRlInfo { vwrlNm = n, vwrlPos = p, vwrlJdBldL = b, vwrlAuxGroups = g } + +vwrlPreGam :: VwRlInfo e -> REGam e +vwrlPreGam v = gamUnions [ g | (RlJdBldDirect _ g _) <- vwrlJdBldL v ] + +vwrlPostGam :: VwRlInfo e -> REGam e +vwrlPostGam v = gamUnions [ g | (RlJdBldDirect _ _ g) <- vwrlJdBldL v ] + +vwrlExtNmS :: VwRlInfo e -> Set.Set Nm +vwrlExtNmS v = Set.unions [ e | (RlJdBldDirect e _ _) <- vwrlJdBldL v ] + +instance Show (VwRlInfo e) where + show _ = "VwRlInfo" + +instance PP e => PP (VwRlInfo e) where + pp i = "VWRl" >#< pp (vwrlNm i) >#< (ppBracketsCommas (vwrlJdBldL i) + >-< ppBracketsCommas (vwrlJdBldOnAL i) + >-< ppBracketsCommas (vwrlJdBldOnBL i) + >-< ppGam (vwrlFullNoDfltPreGam i) + >-< ppGam (vwrlFullNoDfltPostGam i) + >-< ppGam (vwrlFullPreGam i) + >-< ppGam (vwrlFullPostGam i) + >-< pp (show (vwrlPreScc i)) + >-< maybe empty (ppGam . gamMap ppGam) (vwrlMbChGam i) + >-< pp (show (vwrlAuxGroups i)) + ) + +type VwRlGam e = Gam Nm (VwRlInfo e) + +vwrlDelEmptyJd :: VwRlInfo e -> VwRlInfo e +vwrlDelEmptyJd i + = i { vwrlFullPreGam = reGamFilterOutEmpty (vwrlFullPreGam i), vwrlFullPostGam = reGamFilterOutEmpty (vwrlFullPostGam i) } + +vrwlIsEmpty :: VwRlInfo e -> Bool +vrwlIsEmpty i + = gamIsEmpty (vwrlFullPreGam i) && gamIsEmpty (vwrlFullPostGam i) + +vwrlScc :: VwRlInfo e -> [[Nm]] +vwrlScc i + = map reorder . unNm . scc . concat . dpd . vwrlFullPreGam $ i + where dpd g = d' ++ d + where d = [ (jd n,map nm . Set.toList $ is) : zip (map nm . Set.toList $ os) (repeat [jd n]) + | (REInfoJudge n _ is os _ _) <- gamElemsShadow g + ] + d' = [ zipWith (\a b -> (a, [b])) grp (tl ++ [hd]) + | grp@(hd:tl) <- map (map jd) auxGrps + , not (null grp) + ] + nm n = nmSetSel n "n" + jd n = nmSetSel n "j" + unNm scc = [ l' | l <- scc, let l' = [ nmInit n | n <- l, nmSel n == "j" ], not (null l') ] + auxGrps = vwrlAuxGroups i + reorder cfg = foldr reorderForGroup cfg auxGrps + reorderForGroup grp cfg + = let (mem, nmem) = partition (`elem` grp) cfg + smem = sortBy (\x y -> compare (elemIndex x grp) (elemIndex y grp)) mem + in smem ++ nmem + +vwrlUndefs :: VwRlInfo e -> Set.Set Nm +vwrlUndefs i + = (prei `Set.union` posto) `Set.difference` (preo `Set.union` posti) + where nms g + = (Set.unions iss,Set.unions oss) + where (iss,oss) = unzip [ (reInNmS i,reOutNmS i) | i <- gamElemsShadow g ] + (prei,preo) = nms (vwrlFullPreGam i) + (posti,posto) = nms (vwrlFullPostGam i) + +------------------------------------------------------------------------- +-- Rule +------------------------------------------------------------------------- + +data RlInfo e + = RlInfo + { rlNm :: Nm + , rlPos :: SPos + , rlMbOnNm :: Maybe Nm + , rlMbAGStr :: Maybe String + , rlSeqNr :: Int + , rlMbInclVwS :: Maybe (Set.Set Nm) + , rlVwGam :: VwRlGam e + } + +emptyRlInfo = RlInfo nmUnk emptySPos Nothing Nothing 0 Nothing emptyGam + +instance Show (RlInfo e) where + show _ = "RlInfo" + +instance PP e => PP (RlInfo e) where + pp i = "RL" >#< pp (rlNm i) >#< ppGam (rlVwGam i) + +type RlGam e = Gam Nm (RlInfo e) + +rlVwGamLookup :: Nm -> Nm -> RlGam e -> Maybe (RlInfo e,VwRlInfo e) +rlVwGamLookup = dblGamLookup rlVwGam + +rlVwRlOnL :: DtInvGam -> RlGam e -> Nm -> Nm -> RlInfo e -> [VwRlInfo e] +rlVwRlOnL dtInvGam rlGam nSc nVw rlInfo + = on rlInfo + where on i + = case maybe Nothing (\n -> gamLookup n rlGam) (mbOnNm i) of + Just i -> case gamLookup nVw (rlVwGam i) of + Just j -> j : on i + _ -> on i + _ -> [] + mbOnNm i = dtInvGamRlMbOn dtInvGam i nSc nVw + +------------------------------------------------------------------------- +-- Rules +------------------------------------------------------------------------- + +data RsInfo e + = RsInfo + { rsNm :: Nm + , rsPos :: SPos + , rsScNm :: Nm + , rsInclVwS :: Set.Set Nm + , rsDescr :: String + , rsRlGam :: RlGam e + } + | RsInfoGroup + { rsNm :: Nm + , rsPos :: SPos + , rsScNm :: Nm + , rsInclVwS :: Set.Set Nm + , rsDescr :: String + , rsRlNms :: [(Nm,Nm)] + } + +emptyRsInfo = RsInfo nmUnk emptySPos nmUnk Set.empty "" emptyGam + +rsInfoIsPlain :: RsInfo e -> Bool +rsInfoIsPlain (RsInfo _ _ _ _ _ _) = True +rsInfoIsPlain _ = False + +rsInfoIsGroup :: RsInfo e -> Bool +rsInfoIsGroup (RsInfoGroup _ _ _ _ _ _) = True +rsInfoIsGroup _ = False + +instance Show (RsInfo e) where + show _ = "RsInfo" + +instance PP e => PP (RsInfo e) where + pp (RsInfo n _ _ _ _ g) = "RS" >#< pp n >#< ppGam g + pp (RsInfoGroup n _ _ _ _ _) = "RSGrp" >#< pp n + +type RsGam e = Gam Nm (RsInfo e) + +rsRlOrder :: RsInfo e -> [Nm] +rsRlOrder i + = case i of + RsInfo _ _ _ _ _ g -> map snd . sort $ [ (rlSeqNr i,rlNm i) | i <- gamElemsShadow g ] + RsInfoGroup _ _ _ _ _ ns -> map snd ns + +rsInfoMbRlGam :: RsInfo e -> Maybe (RlGam e) +rsInfoMbRlGam (RsInfo _ _ _ _ _ g) = Just g +rsInfoMbRlGam _ = Nothing + +rsRlVwGamLookup :: Nm -> Nm -> Nm -> RsGam e -> Maybe (RsInfo e,RlInfo e,VwRlInfo e) +rsRlVwGamLookup = tripleGamLookup rsRlGam rlVwGam + +%%] diff --git a/src/AttrProps.chs b/src/AttrProps.chs new file mode 100644 --- /dev/null +++ b/src/AttrProps.chs @@ -0,0 +1,46 @@ +------------------------------------------------------------------------- +-- Common stuff w.r.t. attr +------------------------------------------------------------------------- + +%%[1 hs module (AttrProps) +%%] + +%%[1 hs export(AtDir, AtProp(..), propsDir) +%%] + +%%[1 hs import (Data.Set) +%%] + +%%[1 hs import (UHC.Util.Pretty) +%%] + +%%[1 hs + +------------------------------------------------------------------------- +-- Attr props/dir/info +------------------------------------------------------------------------- + +{- +data AtDir + = AtInh | AtSyn | AtIn | AtOut | AtInOut + deriving (Eq,Ord,Show) +-} + +type AtDir = AtProp + +propsDir :: Set AtProp +propsDir = fromList [ AtInh, AtSyn, AtIn, AtOut, AtInOut ] + +data AtProp + = AtNode | AtThread | AtUpdown | AtRetain | AtExtern | AtInh | AtSyn | AtIn | AtOut | AtInOut + deriving (Eq,Ord,Show) + +{- +instance PP AtDir where + pp = text . show +-} + +instance PP AtProp where + pp = text . show + +%%] diff --git a/src/Common.chs b/src/Common.chs new file mode 100644 --- /dev/null +++ b/src/Common.chs @@ -0,0 +1,176 @@ +------------------------------------------------------------------------- +-- Common stuff +------------------------------------------------------------------------- + +%%[1 hs module (Common) +%%] + +%%[1 hs export (module Data.Maybe) +%%] + +%%[1 hs export (module Data.Char) +%%] + +%%[1 hs export (module UHC.Util.Nm) +%%] + +%%[1 hs export (module UHC.Util.DependencyGraph) +%%] + +%%[1 hs export (module UHC.Util.FPath) +%%] + +%%[1 hs export (module AttrProps) +%%] + +%%[1 hs export (module Scanner) +%%] + +%%[1 hs export (rulesCmdPre, ExprIsRw(..), WrKind(..)) +%%] + +%%[1 hs export (strOverl, strOverVec, strUnd, strLhs, strLoc) +%%] + +%%[1 hs export (nmOverl, nmOverVec, nmUnk, nmApp, nmWild, nmNone, nmList) +%%] + +%%[1 hs export (nmEql, nmComma, nmOParen, nmCParen, nmLhs, nmAny, nmSp1) +%%] + +%%[1 hs export (nmUniq, nmCmdBegChng, nmCmdEndChng, nmCmdBegSame, nmCmdEndSame) +%%] + +%%[1 hs export (nmFunMkUniq, nmIsOver, FmKind(..), fmAS2Fm, ScKind(..), ScDeriv(..)) +%%] + +%%[1 hs import (Data.Maybe, Data.Char, System.IO, UHC.Util.Pretty) +%%] + +%%[1 hs import (Scanner( SPos, emptySPos ), UHC.Util.FPath) +%%] + +%%[1 hs import (UHC.Util.ParseErrPrettyPrint, UHC.Util.ScanUtils, UHC.Util.Nm) +%%] + +%%[1 hs import (UHC.Util.DependencyGraph, AttrProps) +%%] + +%%[1 hs + +------------------------------------------------------------------------- +-- Defaults +------------------------------------------------------------------------- + +rulesCmdPre = "rules" + +------------------------------------------------------------------------- +-- Is Expr a complex (non variable expr)? +------------------------------------------------------------------------- + +data ExprIsRw + = ExprIsRw Nm + | ExprIsVar Nm + | ExprIsOther + deriving Show + +instance PP ExprIsRw where + pp = pp . show + +------------------------------------------------------------------------- +-- PP instances +------------------------------------------------------------------------- + +instance (PP a,PP b) => PP (a,b) where + pp (a,b) = pp a >#< ":" >#< pp b + +------------------------------------------------------------------------- +-- Kind of Expr wrappers (for influencing latex pretty printing, colors) +------------------------------------------------------------------------- + +data WrKind + = WrIsChanged | WrIsSame | WrTop | WrNone + deriving (Show,Eq,Ord) + +instance PP WrKind where + pp = text . show + +------------------------------------------------------------------------- +-- Names +------------------------------------------------------------------------- + +strUnd = "_" +strOverl = "_" +strOverVec = ">" +strLhs = "lhs" +strLoc = "loc" + +nmOverl, nmOverVec, nmUnk, nmApp, nmWild, nmNone, nmEql, nmComma, nmOParen, nmCParen, nmLhs, nmAny, nmSp1 :: Nm +nmOverl = Nm strOverl +nmOverVec = Nm strOverVec +nmLhs = Nm strLhs +nmWild = Nm strUnd +nmUnk = Nm "??" +nmAny = Nm "*" +nmSp1 = Nm "^" +nmEql = Nm "=" +nmApp = Nm "$" +nmNone = Nm "" +nmList = Nm "[]" +nmComma = Nm "," +nmOParen = Nm "(" +nmCParen = Nm ")" + +nmUniq :: Int -> Nm +nmUniq u = Nm ("uniq" ++ (if u > 0 then show u else "")) + +nmCmdBegChng, nmCmdEndChng, nmCmdBegSame, nmCmdEndSame :: Nm +nmCmdBegChng = Nm "rulerChngBegMark" +nmCmdEndChng = Nm "rulerChngEndMark" +nmCmdBegSame = Nm "rulerSameBegMark" +nmCmdEndSame = Nm "rulerSameEndMark" + +nmFunMkUniq :: Int -> Nm +nmFunMkUniq u = Nm ("rulerMk" ++ show u ++ "Uniq") + +nmIsOver :: Nm -> Bool +nmIsOver n = nmOverl == n || nmOverVec == n + +------------------------------------------------------------------------- +-- Format kinds +------------------------------------------------------------------------- + +data FmKind + = FmTeX | FmFmtCmd | FmAG | FmHS | FmSpec | FmAll | FmCnstr | FmAS2 FmKind + deriving (Show,Eq,Ord) + +fmAS2Fm :: FmKind -> FmKind +fmAS2Fm (FmAS2 f) = f +fmAS2Fm f = f + +instance PP FmKind where + pp = pp . show + +------------------------------------------------------------------------- +-- Kind of scheme +------------------------------------------------------------------------- + +data ScKind + = ScJudge | ScRelation + deriving (Show,Eq,Ord) + +instance PP ScKind where + pp = text . show + +------------------------------------------------------------------------- +-- Derived scheme +------------------------------------------------------------------------- + +data ScDeriv + = ScList Nm + deriving (Show,Eq,Ord) + +instance PP ScDeriv where + pp (ScList n) = ppBrackets (pp n) + +%%] diff --git a/src/Config.chs b/src/Config.chs new file mode 100644 --- /dev/null +++ b/src/Config.chs @@ -0,0 +1,63 @@ +%%[0 +%include lhs2TeX.fmt +%include afp.fmt +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Module itf +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[1 export(cfgKeywordsOpsEsc,cfgKeywordsOpsExplainEsc,cfgStrSel) +%%] + +%%[1 export(cfgFmFmtCmdAsc) +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Configuration for Ruler and mentioning in documentation +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[1 +cfgKeywordsOpsEsc :: [String] +cfgKeywordsOpsEsc = +%%] +%%[1.cfgKeywordsOpsEsc.val + [ ",", ":", "[", "]", "*", "<", ":=", "::", "->" ] +%%] + +%%[1 +cfgKeywordsOpsExplainEsc :: [String] +cfgKeywordsOpsExplainEsc = +%%] +%%[1.cfgKeywordsOpsExplainEsc.val + [ "=", "-", "---" ] +%%] + +%%[1 +cfgStrSel :: String +cfgStrSel = +%%] +%%[1.cfgStrSel.val + "." +%%] + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%% Names of commands +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +%%[1 +cfgFmFmtCmdAsc :: [(String,String)] +cfgFmFmtCmdAsc = +%%] +%%[1.cfgFmFmtCmdAsc.val + [ ( "rulerChngBegMark", "rulerChngBegMark" ) -- lhs2tex for begin of change + , ( "rulerChngEndMark", "rulerChngEndMark" ) -- lhs2tex for end of change + , ( "rulerSameBegMark", "rulerSameBegMark" ) -- lhs2tex for begin of no change + , ( "rulerSameEndMark", "rulerSameEndMark" ) -- lhs2tex for end of no change + , ( "rulerUndefinedExtern", "rulerUndefinedExtern" ) -- lhs2tex for extern hole + , ( "rulerRulesetFigureEnv", "rulerRulesetFigure" ) -- latex env for ruleset figure + , ( "rulerRuleCmd", "rulerRule" ) -- latex cmd for rule + , ( "rulerCmdUse", "rulerCmdUse" ) -- latex cmd for using generated artefact + , ( "rulerCmdDef", "rulerCmdDef" ) -- latex cmd for defining generated artefact + ] +%%] diff --git a/src/ECnstrGam.chs b/src/ECnstrGam.chs new file mode 100644 --- /dev/null +++ b/src/ECnstrGam.chs @@ -0,0 +1,43 @@ +------------------------------------------------------------------------- +-- ECnstr Gamma +------------------------------------------------------------------------- + +%%[1 hs module (ECnstrGam) +%%] + +%%[1 hs export (module Gam, ECnstrGam, ecGamLookup, ecGamInsert, ecGamFromList) +%%] + +%%[1 hs import (qualified Data.Map as Map, Common, Gam, Expr.Expr) +%%] + +------------------------------------------------------------------------- +-- Gam +------------------------------------------------------------------------- + +%%[1 hs +type ECnstrGam = Gam Expr ECnstr + +ecGamLookup :: Expr -> ECnstrGam -> Maybe ECnstr +ecGamLookup e g = gamLookup (ecStrip e) g + +ecGamInsert :: Expr -> ECnstr -> ECnstrGam -> ECnstrGam +ecGamInsert e c g = gamInsert (ecStrip e) c g + +ecGamFromList :: [(Expr,ECnstr)] -> ECnstrGam +ecGamFromList l = gamFromAssocs [ (ecStrip e,c) | (e,c) <- l ] +%%] + +------------------------------------------------------------------------- +-- Stripping for ECnstr +------------------------------------------------------------------------- + +%%[1 hs +ecStrip :: Expr -> Expr +ecStrip (Expr_Paren e ) = e +-- ecStrip (Expr_AppTop e ) = e +ecStrip (Expr_Cnstr e _) = e +ecStrip (Expr_Retain e ) = e +ecStrip (Expr_Named _ e) = e +ecStrip e = e +%%] diff --git a/src/Err.chs b/src/Err.chs new file mode 100644 --- /dev/null +++ b/src/Err.chs @@ -0,0 +1,108 @@ +------------------------------------------------------------------------- +-- Error +------------------------------------------------------------------------- + +%%[1 hs module (Err) +%%] + +%%[1 hs export (Err(..), mkPPErr, ppErrPPL, errLIsFatal, errFirst, mkTr) +%%] + +%%[1 hs import (UHC.Util.Pretty, UHC.Util.Utils) +%%] + +%%[1 hs import (Scanner( SPos, emptySPos )) +%%] + +%%[1 hs import (UHC.Util.ParseErrPrettyPrint) +%%] + +%%[1 hs import (UHC.Util.Nm, UHC.Util.Utils( maybeHd )) +%%] + +%%[1 hs + +------------------------------------------------------------------------- +-- Errors +------------------------------------------------------------------------- + +data Err + = Err_UndefNm SPos String String [Nm] + | Err_NoJdSpec SPos String [Nm] + | Err_NotInSel SPos String [Nm] + | Err_Dups SPos String String [PP_Doc] + | Err_MutDpds SPos String String [PP_Doc] + | Err_NoXXFor SPos String String [Nm] + | Err_Match SPos String PP_Doc PP_Doc + | Err_RlPost SPos String Nm + | Err_NotAEqnForm SPos PP_Doc + | Err_FileNotFound SPos String [String] + | Err_PP PP_Doc + | Err_Tr PP_Doc + deriving Show + +------------------------------------------------------------------------- +-- Pretty printing +------------------------------------------------------------------------- + +ppErrPPL :: PP a => [a] -> PP_Doc +ppErrPPL = vlist . map pp + +mkPPErr :: PP a => a -> Err +mkPPErr = Err_PP . pp + +mkTr :: (PP a,PP m) => m -> a -> Err +mkTr m p = Err_Tr (pp m >|< ":" >#< pp p) + +instance PP Err where + pp (Err_UndefNm pos cx knd nmL) + = ppErr pos ("In" >#< cx >#< knd >|< "(s) are undefined:" >#< ppCommas' nmL) + pp (Err_Dups pos cx knd nmL) + = ppErr pos (cx >#< "has duplicate" >#< knd >|< "s:" >#< ppCommas' nmL) + pp (Err_MutDpds pos cx knd nmL) + = ppErr pos (cx >#< "has mutually dependent" >#< knd >|< "s:" >#< ppCommas' nmL) + pp (Err_NoXXFor pos cx knd nmL) + = ppErr pos ("In" >#< cx >#< "a" >#< knd >#< "lacks for:" >#< ppCommas' nmL) + pp (Err_NoJdSpec pos cx nmL) + = ppErr pos ("In" >#< cx >#< "no judgespec for:" >#< ppCommas' nmL) + pp (Err_NotInSel pos cx nmL) + = ppErr pos ("In" >#< cx >#< "view is not in selection (implicitly defined by data):" >#< ppCommas' nmL) + pp (Err_Match pos cx given reqd) + = ppErr pos ("In" >#< cx >#< "could not match" + >-< indent 2 + ( "scheme judgement expr:" >#< reqd + >-< "given view expr :" >#< given + ) + ) + pp (Err_RlPost pos cx nm) + = ppErr pos ("In" >#< cx >#< "conclusion lacks judgement for ruleset's scheme:" >#< pp nm) + pp (Err_FileNotFound pos fp sp) + = ppErr pos ("File not found" + >-< indent 2 + ( "file name :" >#< fp + >-< "searched locations:" >#< vlist (map (text.show) sp) + ) + ) + pp (Err_NotAEqnForm pos e) + = ppWarn pos ("expr not of (AG rule) form ... = ...:" >#< e) + pp (Err_PP e) + = e + pp (Err_Tr e) + = ppTr e + +------------------------------------------------------------------------- +-- Misc +------------------------------------------------------------------------- + +errIsFatal :: Err -> Bool +errIsFatal (Err_NotAEqnForm _ _) = False +errIsFatal (Err_Tr _ ) = False +errIsFatal _ = True + +errLIsFatal :: [Err] -> Bool +errLIsFatal es = not (null es) && any errIsFatal es + +errFirst :: [[Err]] -> [Err] +errFirst = firstNotEmpty + +%%] diff --git a/src/Expr/AbsSynAG.cag b/src/Expr/AbsSynAG.cag new file mode 100644 --- /dev/null +++ b/src/Expr/AbsSynAG.cag @@ -0,0 +1,88 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- Expr AST +------------------------------------------------------------------------- + +------------------------------------------------------------------------- +-- Interfacing +------------------------------------------------------------------------- + +DATA AGExprItf + | AGItf expr : Expr + +------------------------------------------------------------------------- +-- Expr +------------------------------------------------------------------------- + +DATA Expr + | AppTop expr : Expr + | App lExpr : Expr + rExpr : Expr + | Op nm : {Nm} + nmExpr : Expr + lExpr : Expr + rExpr : Expr + | LF lExpr : Expr + rExpr : Expr + | SP lExpr : Expr + rExpr : Expr + | Var nm : {Nm} + | AVar anm : ANm + | Int int : {String} + | StrText str : {String} + | StrAsIs str : {String} + | Named nm : {Nm} + expr : Expr + | Wrap wrKind : {WrKind} + expr : Expr + | Cnstr expr : Expr + cnstr : ECnstr + | WrapCnstr cnstr : ECnstr + | Paren expr : Expr + | Retain expr : Expr + | Expr expr : Expr + | SelTop expr : Expr + | Sel expr : Expr + selMbExpr : MbExpr + | ChildOrder seqNr : {Int} + expr : Expr + | Uniq + | Empty + | Undefined + +TYPE MbExpr = MAYBE Expr + +------------------------------------------------------------------------- +-- ANm +------------------------------------------------------------------------- + +DATA ANm + | Wild + | Loc nm : {Nm} + props : {[AtProp]} + | Lhs nm : {Nm} + props : {[AtProp]} + | Fld nm : {Nm} + | Node ndNm : {Nm} + nm : {Nm} + +------------------------------------------------------------------------- +-- Expr constraint +------------------------------------------------------------------------- + +DATA ECnstr + | Ty nms : {[Nm]} + | Var nm : {Nm} + | Empty + +------------------------------------------------------------------------- +-- Sets +------------------------------------------------------------------------- + +SET AllExprButANm = Expr MbExpr ECnstr + +SET AllExpr = AllExprButANm ANm + + +%%] diff --git a/src/Expr/CoGam.cag b/src/Expr/CoGam.cag new file mode 100644 --- /dev/null +++ b/src/Expr/CoGam.cag @@ -0,0 +1,70 @@ +------------------------------------------------------------------------- +-- Expr child order +------------------------------------------------------------------------- + +%%[1 hs module (Expr.CoGam) +%%] + +%%[1 hs export (module Gam, ChOrdGam, exprCoGam, coGamNmL) +%%] + +%%[1 hs import (Data.List, qualified Data.Map as Map, Common, Expr.Expr, Gam) +%%] + +%%[1 ag import ({Expr/AbsSynAG}) +%%] + +%%[1 ag +WRAPPER AGExprItf +%%] + +%%[1 hs +exprCoGam :: Expr -> ChOrdGam +exprCoGam e + = coGam_Syn_AGExprItf r2 + where r1 = sem_AGExprItf (AGExprItf_AGItf e) + r2 = wrap_AGExprItf r1 + (Inh_AGExprItf) +%%] + +------------------------------------------------------------------------- +-- Child order +------------------------------------------------------------------------- + +%%[1 hs +type ChOrdGam = Gam Nm Int +%%] + +------------------------------------------------------------------------- +-- Child order as list of names +------------------------------------------------------------------------- + +%%[1 hs +coGamNmL :: ChOrdGam -> [Nm] +coGamNmL coGam + = [nmLhs] ++ l ++ [nmLhs] + where l = map fst . sortBy (\(_,o1) (_,o2) -> compare o1 o2) . gamAssocsShadow $ coGam +%%] + +------------------------------------------------------------------------- +-- Expr child order +------------------------------------------------------------------------- + +%%[1 ag + +ATTR AllExpr ANm AGExprItf [ | | coGam USE {`gamUnion`} {emptyGam}: ChOrdGam ] +ATTR Expr ANm [ | | mbChNm: {Maybe Nm} ] + +SEM ANm + | Fld lhs . mbChNm = Just @nm + | * - Fld lhs . mbChNm = Nothing + +SEM Expr + | * - AVar lhs . mbChNm = Nothing + +SEM Expr + | ChildOrder lhs . coGam = case @expr.mbChNm of + Just n -> gamSingleton n @seqNr + Nothing -> emptyGam + +%%] diff --git a/src/Expr/Expr.cag b/src/Expr/Expr.cag new file mode 100644 --- /dev/null +++ b/src/Expr/Expr.cag @@ -0,0 +1,134 @@ +------------------------------------------------------------------------- +-- Haskell interface to Expr AST +------------------------------------------------------------------------- + +%%[1 hs module (Expr.Expr) +%%] + +%%[1 hs import (qualified Data.Map as Map, Common) +%%] + +%%[1 ag import ({Expr/AbsSynAG}) +%%] + +%%[1 ag +DERIVING AllExpr: Eq,Ord +%%] + +------------------------------------------------------------------------- +-- Observation +------------------------------------------------------------------------- + +%%[1 hs +exprIsCnstr :: Expr -> Bool +exprIsCnstr e + = ic (exprStrip StripFull e) + where ic (Expr_Cnstr _ _) = True + ic _ = False +%%] + +------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------- + +%%[1 hs +mkExprApp :: Expr -> [Expr] -> Expr +mkExprApp f = Expr_AppTop . foldl Expr_App f + +exprUnk :: Expr +exprUnk = Expr_Var nmUnk + +exprMbNm :: Expr -> Maybe Nm +exprMbNm (Expr_Var n) = Just n +exprMbNm _ = Nothing + +exprAsNm :: Expr -> Nm +exprAsNm = maybe nmUnk id . exprMbNm +%%] + +%%[1 hs +mkAFld :: Nm -> Expr +mkAFld n = Expr_AVar (ANm_Fld n) + +mkALoc :: Nm -> Expr +mkALoc n = Expr_AVar (ANm_Loc n []) + +mkALoc' :: Nm -> Expr +mkALoc' n = mkALoc (nmStrApd n nmWild) + +mkALhs' :: [AtProp] -> Nm -> Expr +mkALhs' p n = Expr_AVar (ANm_Lhs n p) + +mkALhs :: Nm -> Expr +mkALhs = mkALhs' [] + +mkANd :: Nm -> Nm -> Expr +mkANd n a = Expr_AVar (ANm_Node n a) +%%] + +------------------------------------------------------------------------- +-- Rename map +------------------------------------------------------------------------- + +%%[1 hs +data RnSrc = RnNm ANm | RnExpr Expr | RnNone + +rnSrc2Expr :: RnSrc -> Expr +rnSrc2Expr (RnNm a) = Expr_AVar a +rnSrc2Expr (RnExpr e) = e + +type RnMp = Map.Map Nm (Int,RnSrc) + +rnMpUnion :: RnMp -> RnMp -> RnMp +rnMpUnion m1 m2 + = Map.unionWith (\(c1,v1) (c2,v2) -> (c1+c2,u v1 v2)) m1 m2 + where u RnNone r = r + u r _ = r +%%] + +------------------------------------------------------------------------- +-- Ensure AppTop on top +------------------------------------------------------------------------- + +%%[1 hs +exprEnsureAppTop :: Expr -> Expr +exprEnsureAppTop e@(Expr_App _ _ ) = Expr_AppTop e +exprEnsureAppTop e@(Expr_Op _ _ _ _) = Expr_AppTop e +exprEnsureAppTop e = e +%%] + +------------------------------------------------------------------------- +-- Split into lines +------------------------------------------------------------------------- + +%%[1 hs +exprLines :: Expr -> [Expr] +exprLines (Expr_LF l r) = l : exprLines r +exprLines j = [j] +%%] + +------------------------------------------------------------------------- +-- Strip syntactic sugar like structure +------------------------------------------------------------------------- + +%%[1 hs +data ExprStrip = StripBasicNoPar | StripBasic | StripFullNoTop | StripFull deriving (Eq,Ord) + +exprStrip' :: ExprStrip -> Expr -> (Expr,Expr->Expr,[Expr]) +exprStrip' s e + = str e + where str te@(Expr_AppTop e) | s >= StripBasicNoPar && s /= StripFullNoTop + = sub Expr_AppTop te e + str te@(Expr_Paren e) | s >= StripBasic = sub Expr_Paren te e + str te@(Expr_Named n e) | s >= StripBasicNoPar = sub (Expr_Named n) te e + str te@(Expr_Retain e) | s >= StripFull = sub Expr_Retain te e + str te@(Expr_SelTop e) | s >= StripFull = sub Expr_SelTop te e + str te = (te,id,[te]) + sub mkt te e = (e',mkt . mke,te:l) + where (e',mke,l) = str e + +exprStrip :: ExprStrip -> Expr -> Expr +exprStrip s e + = e' + where (e',_,_) = exprStrip' s e +%%] diff --git a/src/Expr/FmGamAG.cag b/src/Expr/FmGamAG.cag new file mode 100644 --- /dev/null +++ b/src/Expr/FmGamAG.cag @@ -0,0 +1,9 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- FmGam +------------------------------------------------------------------------- + +ATTR AllExprButANm AGExprItf [ fmGam: {FmGam Expr} | | ] + +%%] diff --git a/src/Expr/IsRw.cag b/src/Expr/IsRw.cag new file mode 100644 --- /dev/null +++ b/src/Expr/IsRw.cag @@ -0,0 +1,30 @@ +------------------------------------------------------------------------- +-- Is Expr a rewrite expr? (i.e, not a format) +------------------------------------------------------------------------- + +%%[1 hs module (Expr.IsRw) +%%] + +%%[1 hs export (exprIsRw) +%%] + +%%[1 hs import (Common, Expr.Expr) +%%] + +%%[1 ag import ({Expr/AbsSynAG}, {Expr/IsRwAG}) +%%] + +%%[1 ag +WRAPPER AGExprItf +%%] + +%%[1 hs +wrapExpr' :: Expr -> Syn_AGExprItf +wrapExpr' e + = let r1 = sem_AGExprItf (AGExprItf_AGItf e) + in wrap_AGExprItf r1 + (Inh_AGExprItf) + +exprIsRw :: Expr -> ExprIsRw +exprIsRw = exprIsRw_Syn_AGExprItf . wrapExpr' +%%] diff --git a/src/Expr/IsRwAG.cag b/src/Expr/IsRwAG.cag new file mode 100644 --- /dev/null +++ b/src/Expr/IsRwAG.cag @@ -0,0 +1,17 @@ +------------------------------------------------------------------------- +-- Is Expr a complex (non variable expr)? Then it will be used only for parameterized rewrites +------------------------------------------------------------------------- + +%%[1 ag + +ATTR Expr AGExprItf [ | | exprIsRw: ExprIsRw ] + +SEM Expr + | Op lhs . exprIsRw = let nm e = case e of {ExprIsRw n | n /= nmApp -> (`nmApd` n) ; _ -> id} + in ExprIsRw . {- nm @lExpr.exprIsRw . -} nm @rExpr.exprIsRw $ @nm + | App lhs . exprIsRw = ExprIsRw nmApp + | Var lhs . exprIsRw = ExprIsVar @nm + | * - Op Var AppTop App + lhs . exprIsRw = ExprIsOther + +%%] diff --git a/src/Expr/LaTeX.cag b/src/Expr/LaTeX.cag new file mode 100644 --- /dev/null +++ b/src/Expr/LaTeX.cag @@ -0,0 +1,31 @@ +------------------------------------------------------------------------- +-- LaTeX PP for Expr +------------------------------------------------------------------------- + +%%[1 hs module (Expr.LaTeX) +%%] + +%%[1 hs export (exprFmtTeX) +%%] + +%%[1 hs import (qualified Data.Map as Map, UHC.Util.Utils, UHC.Util.Pretty, UHC.Util.PrettyUtils, Common, Opts) +%%] + +%%[1 hs import (LaTeXFmtUtils, Expr.Expr, ARule.RwSubst( fmNmFmtCmd ), FmGam, WrKindGam) +%%] + +%%[1 ag import ({Expr/AbsSynAG}, {Expr/OptsAG}, {Expr/FmGamAG}, {Expr/LaTeXAG}) +%%] + +%%[1 ag +WRAPPER AGExprItf +%%] + +%%[1 hs +exprFmtTeX :: Opts -> FmGam Expr -> Expr -> PP_Doc +exprFmtTeX o g e + = ppLaTeX_Syn_AGExprItf r2 + where r1 = sem_AGExprItf (AGExprItf_AGItf e) + r2 = wrap_AGExprItf r1 + (Inh_AGExprItf { opts_Inh_AGExprItf = o, fmGam_Inh_AGExprItf = g }) +%%] diff --git a/src/Expr/LaTeXAG.cag b/src/Expr/LaTeXAG.cag new file mode 100644 --- /dev/null +++ b/src/Expr/LaTeXAG.cag @@ -0,0 +1,113 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- Pretty printing, LaTeX, Expr +------------------------------------------------------------------------- + +ATTR AGExprItf Expr [ | | ppLaTeX USE {>-<} {empty} : PP_Doc ] + +SEM Expr + | Int loc . ppLaTeX = pp @int + | StrText loc . ppLaTeX = switchLaTeXLhs (mkMBox (text @str)) + | StrAsIs loc . ppLaTeX = pp @str + | App loc . ppLaTeX = @lExpr.ppLaTeX >#< @rExpr.ppLaTeX + | Op loc . ppLaTeX = @lExpr.ppLaTeX >#< @nmExpr.ppLaTeX >#< @rExpr.ppLaTeX + | LF loc . ppLaTeX = @lExpr.ppLaTeX >#< switchLaTeXLhs (mkTexCmdUse "quad" empty) >#< @rExpr.ppLaTeX + | SP loc . ppLaTeX = let c = case @rExpr.exprKind of + EKNm n -> case show n of + (c:_) | isAlpha c -> (>#<) + | otherwise -> (>|<) + _ -> (>#<) + _ -> (>#<) + in @lExpr.ppLaTeX `c` @rExpr.ppLaTeX + | Paren loc . ppLaTeX = (if @lhs.needToParen then ppParens else id) @expr.ppLaTeX + | Cnstr loc . ppLaTeX = @expr.ppLaTeX + | SelTop loc . ppLaTeXSel = ppSelLaTeX ((== nmOverl),(== nmOverVec)) @expr.ppLaTeX (reverse @expr.selL) + loc . ppLaTeX = if @expr.exprKind == EKEmp then empty else @ppLaTeXSel + | Sel lhs . ppLaTeX = @expr.ppLaTeX + | Var loc . ppLaTeX = ppNmLaTeX . nmLhs2TeXSafe $ @nm + | Wrap loc . ppLaTeX = let wr o c e + = switchLaTeXLhs (mkTexCmdUse (show o) empty) >#< e >#< switchLaTeXLhs (mkTexCmdUse (show c) empty) + in case gamLookup @wrKind wrKindGam of + Just i -> wr beg end @expr.ppLaTeX + where beg = fmNmFmtCmd @lhs.opts @lhs.fmGam $ wkBegCmd i + end = fmNmFmtCmd @lhs.opts @lhs.fmGam $ wkEndCmd i + _ -> @expr.ppLaTeX + | ChildOrder loc . ppLaTeX = @expr.ppLaTeX + | Expr lhs . ppLaTeX = ensureTeXMath . switchLaTeXLhs' $ @expr.ppLaTeX + | Empty loc . ppLaTeX = empty + | Undefined loc . ppLaTeX = pp (fmNmFmtCmd @lhs.opts @lhs.fmGam $ Nm "rulerUndefinedExtern") + +------------------------------------------------------------------------- +-- Maybe Pretty printing, LaTeX +------------------------------------------------------------------------- + +ATTR MbExpr [ | | mbPPLaTeX: {Maybe (Nm,PP_Doc)} ] + +SEM MbExpr + | Nothing lhs . mbPPLaTeX = Nothing + | Just lhs . mbPPLaTeX = Just (@just.txt,@just.ppLaTeX) + +------------------------------------------------------------------------- +-- Need parenthesis +------------------------------------------------------------------------- + +ATTR MbExpr Expr [ needToParen: Bool | | ] + +SEM Expr + | Sel selMbExpr . needToParen = False + expr . needToParen = case @selMbExpr.mbPPLaTeX of + Just (n,_) | nmIsOver n + -> False + _ -> case @expr.exprKind of + EKNm _ -> False + _ -> @lhs.needToParen + | Paren App Op SelTop SP + loc . needToParen = True + +SEM AGExprItf + | AGItf loc . needToParen = True + +%%] + +------------------------------------------------------------------------- +-- Empty expr? +------------------------------------------------------------------------- + +%%[1 hs +data ExprKind = EKEmp | EKNm Nm | EKOther deriving Eq +%%] + +%%[1 ag + +ATTR Expr [ | | exprKind: ExprKind ] + +SEM Expr + | Empty lhs . exprKind = EKEmp + | Var lhs . exprKind = EKNm @nm + | Sel lhs . exprKind = @expr.exprKind + | * - Var Empty Sel AppTop Paren + lhs . exprKind = EKOther + +------------------------------------------------------------------------- +-- Selections info +------------------------------------------------------------------------- + +ATTR Expr [ | | selL: {[Maybe (Nm,PP_Doc)]}] + +SEM Expr + | Sel lhs . selL = @selMbExpr.mbPPLaTeX : @expr.selL + | * - Sel lhs . selL = [] + +------------------------------------------------------------------------- +-- Just the text of a name +------------------------------------------------------------------------- + +ATTR Expr [ | | txt USE {`const`} {nmNone}: Nm ] + +SEM Expr + | Var lhs . txt = @nm + | StrText StrAsIs lhs . txt = Nm @str + | App SelTop Op lhs . txt = nmNone + +%%] diff --git a/src/Expr/NmS.cag b/src/Expr/NmS.cag new file mode 100644 --- /dev/null +++ b/src/Expr/NmS.cag @@ -0,0 +1,28 @@ +------------------------------------------------------------------------- +-- Is Expr a rewrite expr? (i.e, not a format) +------------------------------------------------------------------------- + +%%[1 hs module (Expr.NmS) +%%] + +%%[1 hs export(exprNmS) +%%] + +%%[1 hs import (qualified Data.Set as Set, Common, Expr.Expr) +%%] + +%%[1 ag import({Expr/AbsSynAG}, {Expr/NmSAG}) +%%] + +%%[1 ag +WRAPPER AGExprItf +%%] + +%%[1 hs +exprNmS :: Expr -> Set.Set Nm +exprNmS e + = nmS_Syn_AGExprItf r2 + where r1 = sem_AGExprItf (AGExprItf_AGItf e) + r2 = wrap_AGExprItf r1 + (Inh_AGExprItf) +%%] diff --git a/src/Expr/NmSAG.cag b/src/Expr/NmSAG.cag new file mode 100644 --- /dev/null +++ b/src/Expr/NmSAG.cag @@ -0,0 +1,16 @@ +------------------------------------------------------------------------- +-- Expr name occurrences +------------------------------------------------------------------------- + +%%[1 ag + +ATTR AllExpr AGExprItf [ | | nmS USE {`Set.union`} {Set.empty}: {Set.Set Nm} ] + +SEM Expr + | Var lhs . nmS = Set.singleton @nm + | Op lhs . nmS = (@nm `Set.delete` @nmExpr.nmS) `Set.union` @lExpr.nmS `Set.union` @rExpr.nmS + +SEM ANm + | Loc lhs . nmS = Set.singleton @nm + +%%] diff --git a/src/Expr/OptsAG.cag b/src/Expr/OptsAG.cag new file mode 100644 --- /dev/null +++ b/src/Expr/OptsAG.cag @@ -0,0 +1,7 @@ +------------------------------------------------------------------------- +-- Global info +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllExpr AGExprItf [ opts: {Opts} | | ] +%%] diff --git a/src/Expr/PrettyPrintAG.cag b/src/Expr/PrettyPrintAG.cag new file mode 100644 --- /dev/null +++ b/src/Expr/PrettyPrintAG.cag @@ -0,0 +1,95 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- PP for Expr +------------------------------------------------------------------------- + +ATTR AllExpr AGExprItf [ | | pp USE {>-<} {empty} : PP_Doc ] + +SEM Expr + | App lhs . pp = exprNeedPar ParCtxtAppL nmUnk @lExpr.self @lExpr.pp + >#< exprNeedPar ParCtxtAppR nmUnk @rExpr.self @rExpr.pp + | Op lhs . pp = let op = if @nm == nmSp1 then empty else @nmExpr.pp + in ppExprMbEmpty @lExpr.self (>|< " ") + (exprNeedPar ParCtxtOpL @nm @lExpr.self @lExpr.pp) + >|< op + >|< ppExprMbEmpty @rExpr.self (" " >|<) + (exprNeedPar ParCtxtOpR @nm @rExpr.self @rExpr.pp) + | LF lhs . pp = exprNeedPar ParCtxtAppR nmUnk @lExpr.self @lExpr.pp + >-< exprNeedPar ParCtxtAppR nmUnk @rExpr.self @rExpr.pp + | SP lhs . pp = @lExpr.pp >|< @rExpr.pp + | Int lhs . pp = pp @int + | StrText StrAsIs lhs . pp = pp @str + | Named lhs . pp = @expr.pp + | Cnstr lhs . pp = ppCurlys (@expr.pp >|< "|" >|< @cnstr.pp) + | Uniq lhs . pp = pp "?uniq?" + | Undefined lhs . pp = pp "_" +SEM Expr + | Sel lhs . pp = exprNeedPar ParCtxtOther nmUnk @expr.self @expr.pp >|< cfgStrSel >|< @selMbExpr.pp + | Var lhs . pp = pp @nm + | Paren lhs . pp = {-ppParens-} @expr.pp + | AppTop lhs . pp = @expr.pp +{- +-} +{- +SEM Expr + | Sel lhs . pp = ppBrackets ("SEL" >#< exprNeedPar ParCtxtOther nmUnk @expr.self @expr.pp) >|< cfgStrSel >|< @selMbExpr.pp + | Var lhs . pp = ppBrackets ("VAR" >#< pp @nm) + | AVar lhs . pp = ppBrackets ("AVR" >#< @anm.pp) + | Paren lhs . pp = ppBrackets ("PAR" >#< @expr.pp) + | AppTop lhs . pp = ppBrackets ("TOP" >#< @expr.pp) +-} + +SEM ECnstr + | Ty lhs . pp = ppCommas' @nms + | Var lhs . pp = pp @nm + +SEM ANm + | Wild loc . nm = nmWild + lhs . pp = ppDest "W" @lhs.isDest @lhs.mbDstWd @lhs.mbPrevNdStr "" "" @nm + | Loc lhs . pp = ppDest "L" @lhs.isDest @lhs.mbDstWd @lhs.mbPrevNdStr @ndStr "" @nm + | Lhs lhs . pp = ppDest "P" @lhs.isDest @lhs.mbDstWd @lhs.mbPrevNdStr @ndStr @ndStr @nm + | Fld lhs . pp = ppDest "F" @lhs.isDest @lhs.mbDstWd @lhs.mbPrevNdStr "??" @ndStr @nm + | Node lhs . pp = ppDest "N" @lhs.isDest @lhs.mbDstWd @lhs.mbPrevNdStr @ndStr @ndStr @nm + +------------------------------------------------------------------------- +-- Context of ANm +------------------------------------------------------------------------- + +ATTR ANm [ isDest: Bool | | ] + +SEM Expr + | AVar anm . isDest = False + +------------------------------------------------------------------------- +-- ARule max column width info, for tabular like PP +------------------------------------------------------------------------- + +ATTR ANm [ mbDstWd: {Maybe (Int,Int)} | | mxDstNdWd, mxDstAtWd USE {`max`} {0}: Int ] + +SEM ANm + | Loc Lhs lhs . mxDstNdWd = 3 + | Wild lhs . mxDstNdWd = 0 + | Node lhs . mxDstNdWd = length @ndStr + | * lhs . mxDstAtWd = length . show $ @nm + +SEM Expr + | AVar loc . mbDstWd = Nothing + +------------------------------------------------------------------------- +-- Node name of AEqnDest in an AEqn, for emitting only first of a series of same node names +------------------------------------------------------------------------- + +ATTR ANm [ | | ndStr: String ] +ATTR ANm [ mbPrevNdStr: {Maybe String} | | ] + +SEM ANm + | Loc loc . ndStr = strLoc + | Lhs loc . ndStr = if AtRetain `elem` @props then strLoc else strLhs + | Node loc . ndStr = show @ndNm + | Fld Wild loc . ndStr = "" + +SEM Expr + | AVar loc . mbPrevNdStr = Nothing + +%%] diff --git a/src/Expr/RwExprGamAG.cag b/src/Expr/RwExprGamAG.cag new file mode 100644 --- /dev/null +++ b/src/Expr/RwExprGamAG.cag @@ -0,0 +1,7 @@ +------------------------------------------------------------------------- +-- RwExprGam +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllExprButANm AGExprItf [ rwGam: RwExprGam | | ] +%%] diff --git a/src/Expr/SelfAG.cag b/src/Expr/SelfAG.cag new file mode 100644 --- /dev/null +++ b/src/Expr/SelfAG.cag @@ -0,0 +1,8 @@ +------------------------------------------------------------------------- +-- Self +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllExpr [ | | self: SELF ] +ATTR AGExprItf [ | | self: Expr ] +%%] diff --git a/src/Expr/ToAEqn.chs b/src/Expr/ToAEqn.chs new file mode 100644 --- /dev/null +++ b/src/Expr/ToAEqn.chs @@ -0,0 +1,109 @@ +------------------------------------------------------------------------- +-- (A)Eqn as Expr +------------------------------------------------------------------------- + +%%[1 hs module (Expr.ToAEqn) +%%] + +%%[1 hs export (exprMbAEqnRest, mkExprEqn, exprCheckAEqnForm) +%%] + +%%[1 hs import (qualified Data.Set as Set, qualified Data.Map as Map, Common, Expr.Expr) +%%] + +%%[1 hs import (Expr.NmS, ARule.ARule, Gam, FmGam) +%%] + +------------------------------------------------------------------------- +-- Construct Expr of the form later to be dissected into AEqn +------------------------------------------------------------------------- + +%%[1 hs +mkExprEqn :: Expr -> Expr -> Expr +mkExprEqn l r = Expr_AppTop (Expr_Op (nmEql) (Expr_Var (nmEql)) l r) +%%] + +------------------------------------------------------------------------- +-- Expr dissected as AEqn (as constructed by mkExprEqn) +------------------------------------------------------------------------- + +%%[1 hs +exprCheckAEqnForm :: Expr -> Maybe (Map.Map Expr Expr) +exprCheckAEqnForm e + = eqn (exprStrip StripBasic e) + where eqn (Expr_Op n _ l r) | n == nmEql = Just (lr l r `Map.union` tup l r) + eqn e = Nothing + tup (Expr_Op ln _ l1 l2) + (Expr_Op rn _ r1 r2) | ln == nmComma && rn == nmComma + = lr l1 r1 `Map.union` tup l1 r1 `Map.union` tup l2 r2 + tup l r = Map.empty + lr l r = Map.fromList $ concat $ [ [(l,r),(r,l)] | l <- ls, r <- rs ] + where (_,_,ls) = exprStrip' StripBasic l + (_,_,rs) = exprStrip' StripBasic r +%%] + +------------------------------------------------------------------------- +-- Expr as AEqn +------------------------------------------------------------------------- + +%%[1 hs +exprMbAEqnRest :: Expr -> Maybe (AEqn,[Expr],FmGam Expr) +exprMbAEqnRest expr + = eE (exprStrip StripBasic expr) + where eE (Expr_Op n _ d s) | n == nmEql + = do (d',ed,gd) <- dE (exprStrip StripBasic d) False + (s' ) <- sE s + return (AEqn_Eqn d' s', ed, gd) + eE e = Nothing + dE (Expr_AVar n) _ = return (AEqnDest_One n,[],emptyGam) + dE (Expr_Retain (Expr_AVar (ANm_Loc n p))) _= return (AEqnDest_One (ANm_Loc n (AtRetain:p)),[],emptyGam) + dE (Expr_Var n) _ = vE [] n + dE (Expr_Retain (Expr_Var n)) _ = vE [AtRetain] n + dE (Expr_StrAsIs s) _ = nE [] s + dE (Expr_Retain (Expr_StrAsIs s)) _ = nE [AtRetain] s + dE (Expr_Retain e) p = dE e p + dE (Expr_SelTop e) p = dE e p + dE e@(Expr_Op n _ _ _) p | n == nmComma = tE e + dE (Expr_Sel e (Just s)) _ + = do ne <- dsE e + ns <- dsE s + return (AEqnDest_One (ANm_Node ne ns),[],emptyGam) + dE _ False = Nothing + dE e True = tE e + dsE (Expr_AppTop e) = dsE e + dsE (Expr_Paren e) = dsE e + dsE (Expr_AVar (ANm_Fld n)) = return n + dsE (Expr_Var n) = return n + dsE _ = Nothing + tE e@(Expr_Op n _ _ _) | n == nmComma + = do (dL,eo,go) <- oE e + return (AEqnDest_Many dL,eo,go) + tE e + = return (AEqnDest_One n,[mkExprEqn (Expr_AppTop e) (Expr_AVar n)],emptyGam) + where n = flip ANm_Loc [] . Nm . nmShowAG . foldr nmApd nmWild . take 2 . Set.toList $ exprNmS e + oE (Expr_Op n _ e1 e2) | n == nmComma + = do (e1',ed,gd) <- dE (exprStrip StripBasic e1) True + (e2',eo,go) <- oE e2 + return (e1' : e2', ed ++ eo, gd `gu` go) + oE e + = do (e',ee,ge) <- dE (exprStrip StripBasic e) True + return ([e'],ee,ge) + sE e = return (AExpr_Expr e) + vE props n + = if n == nmWild + then return (AEqnDest_One ANm_Wild,[],emptyGam) + else let a = ANm_Loc (Nm (nmShowAG n)) props + in return (AEqnDest_One a,[],n `gs` Expr_AVar a) + nE props n + = fmap (\n -> (AEqnDest_One n,[],emptyGam)) m + where m = case n of + ('@':'l':'o':'c':'.':nm) -> Just (ANm_Loc (Nm nm) props) + ( 'l':'o':'c':'.':nm) -> Just (ANm_Loc (Nm nm) props) + ('@':'l':'h':'s':'.':nm) -> Just (ANm_Lhs (Nm nm) []) + ( 'l':'h':'s':'.':nm) -> Just (ANm_Lhs (Nm nm) []) + s | s == strUnd -> Just (ANm_Wild) + | otherwise -> Nothing + gu = fmGamUnion + gs n e = fmGamFromList' FmAG [(n,e)] + +%%] diff --git a/src/Expr/Utils.chs b/src/Expr/Utils.chs new file mode 100644 --- /dev/null +++ b/src/Expr/Utils.chs @@ -0,0 +1,16 @@ +------------------------------------------------------------------------- +-- Interface to all Expr transformations and other utilities +------------------------------------------------------------------------- + +%%[1 hs module (Expr.Utils) +%%] + +%%[1 hs export(module Expr.Expr, module Expr.ToAEqn, module Expr.IsRw, module Expr.NmS, module Expr.CoGam, module Expr.LaTeX) +%%] + +%%[1 hs import(Expr.Expr, Expr.ToAEqn, Expr.IsRw, Expr.NmS, Expr.CoGam, Expr.LaTeX) +%%] + +%%[1 hs + +%%] diff --git a/src/FmGam.chs b/src/FmGam.chs new file mode 100644 --- /dev/null +++ b/src/FmGam.chs @@ -0,0 +1,157 @@ +------------------------------------------------------------------------- +-- Format Gamma +------------------------------------------------------------------------- + +%%[1 hs module(FmGam) +%%] + +%%[1 hs export(module Gam) +%%] + +%%[1 hs export(FmInfo(fmKdGam), FmGam, FmGam') +%%] + +%%[1 hs export(fmSingleton, fmNull) +%%] + +%%[1 hs export(fmGamFromList, fmGamFromList') +%%] + +%%[1 hs export(fmGamToList') +%%] + +%%[1 hs export(fmGamUnion, fmGamUnions) +%%] + +%%[1 hs export(fmGamLookup, fmGamMap) +%%] + +%%[1 hs export(FmKdGam, fkGamLookup) +%%] + +%%[1 hs export(FmDrGam, fdGamLookup) +%%] + +%%[1 hs export(RwGam, rwGamLookup, rwSingleton, rwGamUnion) +%%] + +%%[1 hs export(ppRwGam) +%%] + +%%[1 hs import (Data.Maybe) +%%] + +%%[1 hs import (qualified Data.Set as Set) +%%] + +%%[1 hs import (qualified Data.Map as Map) +%%] + +%%[1 hs import (UHC.Util.Pretty) +%%] + +%%[1 hs import (Common) +%%] + +%%[1 hs import (Gam) +%%] + + +%%[1 hs + +------------------------------------------------------------------------- +-- Formats +------------------------------------------------------------------------- + +data FmInfo n e + = FmInfo + { fmNm :: n + , fmKdGam :: FmKdGam e + } + +instance Show (FmInfo n e) where + show _ = "FmInfo" + +instance (PP n,PP e) => PP (FmInfo n e) where + pp i = "FM" >#< pp (fmNm i) >#< (ppGam . fmKdGam $ i) + +type FmGam' n e = Gam n (FmInfo n e) +type FmGam e = FmGam' Nm e + +fmSingleton :: Ord n => n -> FmKind -> e -> FmGam' n e +fmSingleton n k e = gamSingleton n (FmInfo n (gamSingleton k e)) + +fmNull :: FmGam e -> Bool +fmNull = all (gamIsEmpty . fmKdGam) . gamElemsShadow + +fmGamFromList' :: Ord n => FmKind -> [(n,e)] -> FmGam' n e +fmGamFromList' fk = gamUnionsShadow . map (\(n,e) -> fmSingleton n fk e) + +fmGamToList' :: FmKind -> FmGam e -> [(Nm,e)] +fmGamToList' fk g = [ (n,e) | (n,i) <- gamAssocsShadow g, e <- fkGamLookup [] (:[]) [fk] (fmKdGam i) ] + +fmGamFromList :: [(Nm,e)] -> FmGam e +fmGamFromList = fmGamFromList' FmAll + +fmGamUnion :: Ord n => FmGam' n e -> FmGam' n e -> FmGam' n e +fmGamUnion = gamUnionWith (\i1 i2 -> i1 {fmKdGam = fmKdGam i1 `gamUnionShadow` fmKdGam i2}) + +fmGamUnions :: [FmGam e] -> FmGam e +fmGamUnions = foldr fmGamUnion emptyGam + +{- +fmLGamUnion :: FmGam [e] -> FmGam [e] -> FmGam [e] +fmLGamUnion = gamUnionWith (\i1 i2 -> i1 {fmKdGam = gamUnionWith (++) (fmKdGam i1) (fmKdGam i2)}) +-} + +fmGamLookup :: Ord n => n -> FmKind -> FmGam' n e -> Maybe e +fmGamLookup n k g + = case gamLookup n g of + Just i + -> fkGamLookup Nothing Just [k] (fmKdGam i) + _ -> Nothing + +fmGamMap :: (Nm -> a -> b) -> FmGam a -> FmGam b +fmGamMap f = gamMapWithKey (\n i -> i {fmKdGam = gamMap (\e -> f n e) (fmKdGam i)}) + +------------------------------------------------------------------------- +-- FmGam for FmKind +------------------------------------------------------------------------- + +type FmKdGam e = Gam FmKind e + +fkGamLookup :: v -> (e -> v) -> [FmKind] -> FmKdGam e -> v +fkGamLookup = gamTryLookupsWithDefault FmAll + +------------------------------------------------------------------------- +-- FmGam for AtDir +------------------------------------------------------------------------- + +type FmDrGam e = Gam AtDir e + +fdGamLookup :: v -> (e -> v) -> [AtDir] -> FmDrGam e -> v +fdGamLookup = gamTryLookupsWithDefault AtInOut + +------------------------------------------------------------------------- +-- Rewrite rules +------------------------------------------------------------------------- + +type RwGam e = FmGam (FmDrGam [e]) + +rwGamLookup :: Nm -> FmKind -> AtDir -> RwGam e -> Maybe [e] +rwGamLookup n k d g + = case fmGamLookup n k g of + Just g' + -> fdGamLookup Nothing Just [d] g' + _ -> Nothing + +rwSingleton :: Nm -> FmKind -> AtDir -> e -> RwGam e +rwSingleton n k d e = gamSingleton n (FmInfo n (gamSingleton k (gamSingleton d [e]))) + +rwGamUnion :: RwGam e -> RwGam e -> RwGam e +rwGamUnion = gamUnionWith (\i1 i2 -> i1 {fmKdGam = gamUnionWith (gamUnionWith (++)) (fmKdGam i1) (fmKdGam i2)}) + +ppRwGam :: PP e => RwGam e -> PP_Doc +ppRwGam = ppGam' . gamMap (\i -> fmNm i >#< ppGam (fmKdGam i)) + +%%] diff --git a/src/FmGamAG.cag b/src/FmGamAG.cag new file mode 100644 --- /dev/null +++ b/src/FmGamAG.cag @@ -0,0 +1,8 @@ +------------------------------------------------------------------------- +-- FmGam +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllDecl [ fmGam: {FmGam Expr} | | ] +ATTR AGItf [ fmGam: {FmGam Expr} | | ] +%%] diff --git a/src/Gam.chs b/src/Gam.chs new file mode 100644 --- /dev/null +++ b/src/Gam.chs @@ -0,0 +1,326 @@ +------------------------------------------------------------------------- +-- Gamma +------------------------------------------------------------------------- + +%%[1 hs module(Gam) +%%] + +%%[1 hs export ( Gam, emptyGam, gamIsEmpty, gamSingleton, gamMember) +%%] + +%%[1 hs export (gamTryLookups, gamTryLookupsWithDefault) +%%] + +%%[1 hs export (gamLookup, gamLookupMaybe, gamLookupJust, gamFindWithDefault) +%%] + +%%[1 hs export (gamUnions, gamUnionsShadow, gamUnion, gamUnionShadow, gamUnionWith) +%%] + +%%[1 hs export (gamDelete) +%%] + +%%[1 hs export (gamInsert, gamInsertShadow) +%%] + +%%[1 hs export (gamDifference, gamIntersection) +%%] + +%%[1 hs export (gamToMap) +%%] + +%%[1 hs export (gamAssocs, gamAssocsShadow, gamFromAssocs, gamFromAssocsWith) +%%] + +%%[1 hs export (gamElems, gamElemsShadow) +%%] + +%%[1 hs export (gamKeys) +%%] + +%%[1 hs export (gamMap, gamMapKeys, gamMapWithKey) +%%] + +%%[1 hs export (gamFilterWithKey, gamFilter) +%%] + +%%[1 hs export (gamPartition) +%%] + +%%[1 hs export (gamMapAccumWithKey) +%%] + +%%[1 hs export (gamFold, gamFoldWithKey) +%%] + +%%[1 hs export (gamCheckDups) +%%] + +%%[1 hs export (ppGam, ppGam') +%%] + +%%[1 hs export (dblGamLookup, tripleGamLookup) +%%] + +%%[1 hs export (GamMerge(..)) +%%] + +%%[1 hs import (Data.Maybe) +%%] + +%%[1 hs import (qualified Data.Map as Map) +%%] + +%%[1 hs import (UHC.Util.Pretty) +%%] + +%%[1 hs import (UHC.Util.Utils) +%%] + +%%[1 hs import (Err) +%%] + +%%[1 hs import (Common) +%%] + + +%%[1 + +------------------------------------------------------------------------- +-- Gam +------------------------------------------------------------------------- + +type Gam k v = Map.Map k [v] + +liftList :: (v -> v -> v) -> ([v] -> [v] -> [v]) +liftList f = \(v1:v1s) (v2:v2s) -> [f v1 v2] ++ v1s ++ v2s + +liftList2 :: (v -> v -> v) -> ([v] -> [v] -> [v]) +liftList2 f = \v1s v2s -> [foldr1 f (v1s ++ v2s)] + +liftAnyWithKey :: (k -> v -> w) -> (k -> [v] -> w) +liftAnyWithKey f = \k (v:_) -> f k v + +liftAny :: (v -> w) -> ([v] -> w) +liftAny f = \(v:_) -> f v + +liftMap :: (v -> w) -> ([v] -> [w]) +liftMap = map + +liftMapKey :: (k -> v -> w) -> (k -> [v] -> [w]) +liftMapKey f k = map (f k) + +liftMapAccumKey :: (a -> k -> b -> (a, c)) -> (a -> k -> [b] -> (a, [c])) +liftMapAccumKey f a k bs + = l a bs + where l a [] = (a,[]) + l a (b:bs) = (a3,c:cs) + where (a2,c ) = f a k b + (a3,cs) = l a2 bs + +liftFoldKey :: (k -> v -> a -> a) -> (k -> [v] -> a -> a) +liftFoldKey f k vs a + = l a vs + where l a [] = a + l a (v:vs) = l (f k v a) vs + +liftFold :: (v -> a -> a) -> ([v] -> a -> a) +liftFold f vs a + = l a vs + where l a [] = a + l a (v:vs) = l (f v a) vs + +liftAssocs :: [(k,v)] -> [(k,[v])] +liftAssocs = map (\(k,v) -> (k,[v])) + +gamSingleton :: k -> v -> Gam k v +gamSingleton k v = Map.singleton k [v] + +gamLookup :: Ord k => k -> Gam k v -> Maybe v +gamLookup k = fmap head . Map.lookup k + +gamLookupMaybe :: Ord k => w -> (v -> w) -> k -> Gam k v -> w +gamLookupMaybe n j k = maybe n j . gamLookup k + +gamLookupJust :: Ord k => k -> Gam k v -> v +gamLookupJust = gamLookupMaybe (panic "gamLookupJust") id + +gamAssocsShadow :: Gam k v -> [(k,v)] +gamAssocsShadow = Map.assocs . Map.map head + +gamAssocs' :: Gam k v -> [[(k,v)]] +gamAssocs' g = [ zip (repeat k) vs | (k,vs) <- Map.assocs g ] + +gamAssocs :: Gam k v -> [(k,v)] +gamAssocs = concat . gamAssocs' + +gamElemsShadow :: Gam k v -> [v] +gamElemsShadow = map head . Map.elems + +gamElems :: Gam k v -> [v] +gamElems = concat . Map.elems + +gamFromAssocs :: Ord k => [(k,v)] -> Gam k v +gamFromAssocs = Map.fromListWith (++) . liftAssocs + +gamFromAssocsWith :: Ord k => (v -> v -> v) -> [(k,v)] -> Gam k v +gamFromAssocsWith f = Map.fromListWith (liftList f) . liftAssocs + +gamToMap :: Gam k v -> Map.Map k v +gamToMap = Map.map head + +gamUnionWith :: Ord k => (v -> v -> v) -> Gam k v -> Gam k v -> Gam k v +gamUnionWith f = Map.unionWith (liftList f) + +gamUnion :: Ord k => Gam k v -> Gam k v -> Gam k v +gamUnion = Map.unionWith (++) + +gamUnionShadow :: Ord k => Gam k v -> Gam k v -> Gam k v +gamUnionShadow = Map.unionWith const + +gamUnions :: Ord k => [Gam k v] -> Gam k v +gamUnions = Map.unionsWith (++) + +gamUnionsShadow :: Ord k => [Gam k v] -> Gam k v +gamUnionsShadow = Map.unionsWith const + +gamInsert :: Ord k => k -> v -> Gam k v -> Gam k v +gamInsert k v = Map.insertWith (++) k [v] + +gamInsertShadow :: Ord k => k -> v -> Gam k v -> Gam k v +gamInsertShadow k v = Map.insertWith const k [v] + +gamFilterWithKey :: Ord k => (k -> v -> Bool) -> Gam k v -> Gam k v +gamFilterWithKey f = Map.filterWithKey (liftAnyWithKey f) + +gamFilter :: Ord k => (v -> Bool) -> Gam k v -> Gam k v +gamFilter f = Map.filter (liftAny f) + +gamPartition :: Ord k => (v -> Bool) -> Gam k v -> (Gam k v,Gam k v) +gamPartition f = Map.partition (liftAny f) + +gamMap :: (v -> w) -> Gam k v -> Gam k w +gamMap f = Map.map (liftMap f) + +gamMapWithKey :: (k -> v -> w) -> Gam k v -> Gam k w +gamMapWithKey f = Map.mapWithKey (liftMapKey f) + +gamMapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> Gam k b -> (a, Gam k c) +gamMapAccumWithKey f = Map.mapAccumWithKey (liftMapAccumKey f) + +gamFoldWithKey :: (k -> v -> a -> a) -> a -> Gam k v -> a +gamFoldWithKey f = Map.foldrWithKey (liftFoldKey f) + +gamFold :: (v -> a -> a) -> a -> Gam k v -> a +gamFold f = Map.fold (liftFold f) + +gamKeysWithDup :: Gam k v -> [k] +gamKeysWithDup g = [ k | (k,(_:_:_)) <- Map.toList g ] + +------------------------------------------------------------------------- +-- Gam v1 & v2 share +------------------------------------------------------------------------- + +emptyGam :: Gam k v +emptyGam = Map.empty + +gamIsEmpty :: Gam k v -> Bool +gamIsEmpty = Map.null + +gamMember :: Ord k => k -> Gam k v -> Bool +gamMember = Map.member + +gamFindWithDefault :: Ord k => v -> k -> Gam k v -> v +gamFindWithDefault v k = maybe v id . gamLookup k + +gamKeys :: Gam k v -> [k] +gamKeys = Map.keys + +gamDelete :: Ord k => k -> Gam k v -> Gam k v +gamDelete = Map.delete + +gamDifference :: Ord k => Gam k v -> Gam k w -> Gam k v +gamDifference = Map.difference + +gamIntersection :: Ord k => Gam k v -> Gam k w -> Gam k v +gamIntersection = Map.intersection + +gamMapKeys :: Ord j => (k -> j) -> Gam k v -> Gam j v +gamMapKeys = Map.mapKeys + +------------------------------------------------------------------------- +-- Duplicate key detection +------------------------------------------------------------------------- + +gamCheckDups :: PP k => SPos -> String -> String -> Gam k v -> [Err] +gamCheckDups p cx knd g + = if null d then [] else [Err_Dups p cx knd (map pp d)] + where d = gamKeysWithDup g + +------------------------------------------------------------------------- +-- Merging +------------------------------------------------------------------------- + +class GamMerge g where + gamMerge :: g -> g -> g + +instance (Ord k,GamMerge v) => GamMerge (Gam k v) where + gamMerge = Map.unionWith (liftList2 gamMerge) + +------------------------------------------------------------------------- +-- Pretty printing +------------------------------------------------------------------------- + +{- +ppGam :: (PP k, PP v) => Gam k v -> PP_Doc +ppGam = ppListSepV "[" "]" "," . map (\(k,v) -> pp k >#< ":->" >#< pp v) . gamAssocs +-} +ppGam :: (PP k, PP v) => Gam k v -> PP_Doc +ppGam + = ppl . map (ppl . map (\(k,v) -> pp k >#< ":->" >#< pp v)) . gamAssocs' + where ppl = ppListSepV "[" "]" "," + +ppGam' :: (PP k, PP v) => Gam k v -> PP_Doc +ppGam' = vlist . map (\(k,v) -> pp k >#< ":->" >#< pp v) . gamAssocs + +instance (PP k,PP v) => PP (Gam k v) where + pp g = ppGam' g + +------------------------------------------------------------------------- +-- Double/... lookup +------------------------------------------------------------------------- + +contGamLookup :: Ord k => (i1 -> Gam k i2) -> (i2 -> r) -> k -> i1 -> Maybe r +contGamLookup g2Of mk n2 = fmap mk . gamLookup n2 . g2Of + +dblGamLookup :: Ord k => (i1 -> Gam k i2) -> k -> k -> Gam k i1 -> Maybe (i1,i2) +dblGamLookup g2Of n1 n2 g + = case gamLookup n1 g of + Just i1 + -> contGamLookup g2Of ((,) i1) n2 i1 + _ -> Nothing + +tripleGamLookup :: Ord k => (i1 -> Gam k i2) -> (i2 -> Gam k i3) -> k -> k -> k -> Gam k i1 -> Maybe (i1,i2,i3) +tripleGamLookup g2Of g3Of n1 n2 n3 g + = case dblGamLookup g2Of n1 n2 g of + Just (i1,i2) + -> contGamLookup g3Of (\i3 -> (i1,i2,i3)) n3 i2 + _ -> Nothing + +------------------------------------------------------------------------- +-- General purpose lookup with a default key +------------------------------------------------------------------------- + +gamTryLookups :: Ord k => v -> (e -> v) -> [k] -> Gam k e -> v +gamTryLookups dflt extr keys g + = case keys of + (k:ks) -> case gamLookup k g of + Just i -> extr i + Nothing -> gamTryLookups dflt extr ks g + _ -> dflt + +gamTryLookupsWithDefault :: Ord k => k -> v -> (e -> v) -> [k] -> Gam k e -> v +gamTryLookupsWithDefault dfltKey dflt extr keys g + = gamTryLookups dflt extr (keys ++ [dfltKey]) g + +%%] diff --git a/src/JdShpGam.chs b/src/JdShpGam.chs new file mode 100644 --- /dev/null +++ b/src/JdShpGam.chs @@ -0,0 +1,44 @@ +------------------------------------------------------------------------- +-- Judgment Gamma +------------------------------------------------------------------------- + +%%[1 hs module (JdShpGam) +%%] + +%%[1 hs export (JdShpInfo(..), JdShpGam, jdshpgUnionShadow) +%%] + +%%[1 hs import (qualified Data.Set as Set, qualified Data.Map as Map, UHC.Util.Pretty, Common, Gam, FmGam) +%%] + +------------------------------------------------------------------------- +-- Judgement formats +------------------------------------------------------------------------- + +%%[1 hs +data JdShpInfo e + = JdShpInfo + { jdshExpr :: e + } + | JdShpDel + +instance Show (JdShpInfo e) where + show _ = "JdShpInfo" + +instance PP e => PP (JdShpInfo e) where + pp (JdShpInfo e) = "Jd" >#< pp e + pp (JdShpDel ) = pp "JdShpDel" + +type JdShpGam e = FmKdGam (JdShpInfo e) + +jdshpgUnionShadow :: JdShpGam e -> JdShpGam e -> JdShpGam e +jdshpgUnionShadow gn g + = gamFoldWithKey + (\fk i g + -> case i of + JdShpDel -> gamDelete fk g + _ -> gamInsertShadow fk i g + ) + g gn + +%%] diff --git a/src/KeywParser.chs b/src/KeywParser.chs new file mode 100644 --- /dev/null +++ b/src/KeywParser.chs @@ -0,0 +1,138 @@ +------------------------------------------------------------------------- +-- Keyw/sym parser +------------------------------------------------------------------------- + +%%[1 hs module (KeywParser) +%%] + +%%[1 hs export (specialChars, opChars, propsSynInhMp, propsDirMp, propsMp) +%%] + +%%[1 hs export (keywordsTextDir, keywordsTextProps, keywordsTextEscapable, keywordsText, keywordsOpsEsc) +%%] + +%%[1 hs export (keywordsOpsExplainEsc, keywordsOpsParenEsc, keywordsOps) +%%] + +%%[1 hs export (mkScan, mkHScan, mkOffScan) +%%] + +%%[1 hs export (pKeySPos, pNmStr, pNmStrSPos, pNmStrI, pNmStrISPos, pSymEscStr, pSymEscStrSPos, pSymStr, pSymStrSPos) +%%] + +%%[1 hs import (qualified Data.Map as Map, qualified Data.Set as Set, System.IO, UU.Parsing, UU.Parsing.Offside, Scanner, Config, UHC.Util.ParseUtils, AttrProps, UHC.Util.ScanUtils) +%%] + + +%%[1 hs +------------------------------------------------------------------------- +------------------------------------------------------------------------- +-- Scanning +------------------------------------------------------------------------- + +specialChars = "().`" +opChars = "!#$%&*+/<=>?@\\^|-:;,[]{}~" + +propsSynInhMp + = Map.fromList [ ("thread",AtThread), ("updown",AtUpdown) ] +propsOtherMp + = Map.fromList [ ("retain",AtRetain), ("node",AtNode), ("extern",AtExtern) ] +propsDirMp + = Map.fromList [ ("inh",AtInh), ("syn",AtSyn) ] +propsMp + = Map.unions [ propsSynInhMp, propsOtherMp, propsDirMp ] +keywordsTextProps + = Map.keys propsMp +keywordsTextDir + = Map.keys propsDirMp +keywordsTextEscapable + = keywordsTextProps + ++ [ "judge", "judgeshape", "judgespec", "judgeuse", "relation" + , "rule", "rules", "ruleset" + , "scheme", "view", "hole", "holes", "viewsel", "rulesgroup", "group" + , "explain" + , "data" + -- related to global info + , "viewhierarchy", "format", "rewrite", "preamble" + , "extern", "external" + , "include" + -- related to formatting (styles) + , "tex", "fmtcmd", "ag", "def", "use", "spec" + -- misc + , "text" + ] +keywordsOffsideTrigs + = [ "judges" + ] +keywordsText + = [ "unique" + ] ++ keywordsOffsideTrigs + ++ keywordsTextEscapable +keywordsOpsEsc + = cfgKeywordsOpsEsc +keywordsOpsExplainEsc + = [ cfgStrSel ] ++ cfgKeywordsOpsExplainEsc +keywordsOpsParenEsc + = [ "|" ] ++ keywordsOpsExplainEsc +keywordsOps + = keywordsOpsParenEsc ++ keywordsOpsEsc + +rulerScanOpts :: ScanOpts +rulerScanOpts + = defaultScanOpts + { scoKeywordsTxt = Set.fromList keywordsText + , scoKeywordsOps = Set.fromList keywordsOps + , scoSpecChars = Set.fromList specialChars + , scoOpChars = Set.fromList opChars + , scoOffsideTrigs = keywordsOffsideTrigs + , scoOffsideModule = "" + , scoOffsideOpen = "" + , scoOffsideClose = "" + } + +mkScan :: FilePath -> String -> [Token] +mkScan fn txt = scan rulerScanOpts (initPos fn) txt + +mkHScan :: FilePath -> Handle -> IO [Token] +mkHScan fn fh + = do { txt <- hGetContents fh + ; return (mkScan fn txt) + } + +mkOffScan :: FilePath -> Handle -> IO (OffsideInput [Token] Token (Maybe Token)) +mkOffScan = offsideScanHandle rulerScanOpts + +------------------------------------------------------------------------- +-- Parser +------------------------------------------------------------------------- + +pKeySPos :: (IsParser p Token) => String -> p SPos +pKeySPos k = (\p -> (k,p)) <$> pKeyPos k + +pNmStrSPos, pNmStrISPos :: (IsParser p Token) => p SPos +pNmStrSPos = pVaridPos <|> pConidPos +pNmStrISPos = pNmStrSPos <|> pIntegerPos + +pNmStr, pNmStrI :: (IsParser p Token) => p String +pNmStr = fst <$> pNmStrSPos +pNmStrI = fst <$> pNmStrISPos + +pSymEscStrSPos :: (IsParser p Token) => ([String],[String]) -> p SPos +pSymEscStrSPos (kEsc,kpEsc) + = pVarsymPos <|> pConsymPos + <|> pAnyKey pKeySPos kEsc + <|> pKey "`" *> ( (\(n,p) -> ("`" ++ n ++ "`",p)) <$> pNmStrSPos + <|> (\nl@((_,p):_) -> (concat (map fst nl),p)) <$> pList1 (pAnyKey pKeySPos kpEsc) + ) + <* pKey "`" + +pSymEscStr :: (IsParser p Token) => ([String],[String]) -> p String +pSymEscStr k = fst <$> pSymEscStrSPos k + +pSymStrSPos :: (IsParser p Token) => p SPos +pSymStrSPos = pSymEscStrSPos (keywordsOpsEsc,keywordsOpsParenEsc) + +pSymStr :: (IsParser p Token) => p String +pSymStr = pSymEscStr (keywordsOpsEsc,keywordsOpsParenEsc) + +%%] diff --git a/src/LaTeXFmtUtils.chs b/src/LaTeXFmtUtils.chs new file mode 100644 --- /dev/null +++ b/src/LaTeXFmtUtils.chs @@ -0,0 +1,163 @@ +%%[1 hs module (LaTeXFmtUtils) +%%] + +%%[1 hs export (ppDest, atDstFillLen, atLhs2texDist, NeedParCtxt(..), exprNeedPar, ppExprMbEmpty) +%%] + +%%[1 hs export (strLhs2TeXSafe, nmLhs2TeXSafe, mkMBox, mkInLhs2Tex, ensureTeXMath, switchLaTeXLhs, switchLaTeXLhs') +%%] + +%%[1 hs export (mkCmdNmDef, mkCmdNmUse, ppNmLaTeX, ppSelLaTeX, ppWrapShuffle) +%%] + +%%[1 hs import (UHC.Util.Utils, UHC.Util.Pretty, UHC.Util.PrettyUtils, Common, Expr.Expr) +%%] + +%%[1 hs + +------------------------------------------------------------------------- +-- Formatting for destination names in AG rules +------------------------------------------------------------------------- + +atLhs2texDist = 2 +atLhs2texFill = strWhite atLhs2texDist +atDstFill1 = atLhs2texFill ++ "." ++ atLhs2texFill +atDstFill2 = atLhs2texFill +atDstFillLen = length atDstFill1 + length atDstFill2 + +ppDest :: String -> Bool -> Maybe (Int,Int) -> Maybe String -> String -> String -> Nm -> PP_Doc +ppDest k isDest mbDstWd mbPrevNdStr dstPre srcPre n + = tr $ if isDest + then case mbDstWd of + Just (ndW,atW) + -> strPad (if maybe False (==dstPre) mbPrevNdStr then "" else dstPre) ndW + >|< atDstFill1 >|< strPad (show n) atW >|< atDstFill2 + _ -> mkPre dstPre n + else "@" >|< mkPre srcPre n + where mkPre s n = if null s then pp n else s >|< "." >|< pp n + tr x = x -- (pp k >|< ppCurlys x) + +------------------------------------------------------------------------- +-- Need for parenthesis +------------------------------------------------------------------------- + +data NeedParCtxt + = ParCtxtAppL | ParCtxtAppR | ParCtxtOpL | ParCtxtOpR | ParCtxtOther + deriving Eq + +exprNeedPar :: NeedParCtxt -> Nm -> Expr -> (PP_Doc -> PP_Doc) +exprNeedPar ctxt opNm e + = case e of + Expr_Paren e + -> case (t e,ctxt) of + (Expr_Op _ _ _ _,ParCtxtAppL) -> ppParens + (Expr_Op _ _ _ _,ParCtxtAppR) -> ppParens + (Expr_Op _ _ _ _,ParCtxtOpL ) -> ppParens + (Expr_Op _ _ _ _,ParCtxtOpR ) -> ppParens + (Expr_Op n _ _ _,_ ) + | n == nmComma -> ppParens + (Expr_App _ _ ,ParCtxtAppR) -> ppParens + (Expr_Paren _ ,_ ) -> ppParens + _ | opNm == nmSp1 -> ppParens + | otherwise -> id + _ -> id + where t = exprStrip StripBasicNoPar + +------------------------------------------------------------------------- +-- Misc +------------------------------------------------------------------------- + +ppExprMbEmpty :: Expr -> (PP_Doc -> PP_Doc) -> PP_Doc -> PP_Doc +ppExprMbEmpty (Expr_Empty) _ p = p +ppExprMbEmpty _ f p = f p + +------------------------------------------------------------------------- +-- LaTeX +------------------------------------------------------------------------- + +{- +mkLaTeXNm :: String -> String +mkLaTeXNm = map (\c -> if isAlphaNum c then c else '-') +-} + +strLhs2TeXSafe :: String -> String +strLhs2TeXSafe = concat . map (\c -> if c == '|' then "||" else [c]) + +nmLhs2TeXSafe :: Nm -> Nm +nmLhs2TeXSafe = fmap strLhs2TeXSafe + +mkMBox :: PP a => a -> PP_Doc +mkMBox p = "\\;\\mbox" >|< ppCurly p + +{- +mkRuleNm :: String -> String -> PP_Doc +mkRuleNm r v = "\\textsc" >|< ppCurly (mkLaTeXNm r) >|< (if null v then empty else "_" >|< ppCurly v) +-} + +mkVerb :: PP_Doc -> PP_Doc +mkVerb p = ppPacked "@" "@" p + +switchLaTeXLhs :: PP a => a -> PP_Doc +switchLaTeXLhs p = ppVBar (" " >|< p >|< " ") + +switchLaTeXLhs' :: PP a => a -> PP_Doc +switchLaTeXLhs' = ppPacked "| " " |" + +mkInLhs2Tex :: PP_Doc -> PP_Doc +mkInLhs2Tex p = ppVBar (p >|< " ") + +ensureTeXMath :: PP_Doc -> PP_Doc +ensureTeXMath = mkTexCmdUse "ensuremath" + +mkCmdNmDef :: (PP a, PP b) => a -> b -> PP_Doc +mkCmdNmDef = mkTexCmdDef "rulerCmdDef" + +mkCmdNmUse :: PP a => a -> PP_Doc +mkCmdNmUse = mkTexCmdUse "rulerCmdUse" + +ppNmLaTeX :: Nm -> PP_Doc +ppNmLaTeX n + = ppSelLaTeX ((== strOverl),(== strOverVec)) (fromJust base) (map (fmap (\s -> (s,pp s))) sels) + where (base:sels) = nmToMbL n + +ppSelLaTeX :: (PP base,PP sel) => (sel -> Bool,sel -> Bool) -> base -> [Maybe (sel,PP_Doc)] -> PP_Doc +ppSelLaTeX (isOverl,isOverVec) base sels + = p + where sw = (" " >|<) . switchLaTeXLhs + over n s + = if isOverl n + then sw (text "\\overline{") + else if isOverVec n + then sw (text "\\vec{") + else sw ("\\stackrel{" >|< sw s >|< "}{") + p = case (pp base,sels) of + (x,[Nothing,Nothing,Just (n3,s3)]) + -> over n3 s3 + >|< x + >|< sw (text "}") + (x,[Nothing,Just (_,s2),Just (n3,s3)]) + -> over n3 s3 + >|< x + >|< sw ("^{" >|< sw s2 >|< "}}") + (x,[Just (_,s1),Nothing,Just (n3,s3)]) + -> over n3 s3 + >|< x + >|< sw ("_{" >|< sw s1 >|< "}}") + (x,[Just (_,s1),Just (_,s2),Just (n3,s3)]) + -> over n3 s3 + >|< x + >|< sw ("_{" >|< sw s1 >|< "}^{" >|< sw s2 >|< "}}") + (x,(Just (_,s1):Just (_,s2):_)) + -> x >|< sw ("_{" >|< sw s1 >|< "}^{" >|< sw s2 >|< "}") + (x,(Nothing:Just (_,s2):_)) + -> x >|< sw ("^{" >|< sw s2 >|< "}") + (x,(Just (_,s1):_)) + -> x >|< sw ("_{" >|< sw s1 >|< "}") + (x,_) + -> x + +ppWrapShuffle :: Nm -> PP_Doc -> PP_Doc +ppWrapShuffle n x + = "%%[" >|< n >-< x >-< "%%]" + +%%] diff --git a/src/Main1AG.cag b/src/Main1AG.cag new file mode 100644 --- /dev/null +++ b/src/Main1AG.cag @@ -0,0 +1,486 @@ +------------------------------------------------------------------------- +-- Main for AG, pass 1 +------------------------------------------------------------------------- + +%%[1 hs module (Main1AG) +%%] + +%%[1 hs import (Data.Maybe, Data.Char, Data.List, qualified Data.Set as Set, qualified Data.Map as Map, UHC.Util.Pretty) +%%] + +%%[1 hs import (UHC.Util.FPath, UHC.Util.Utils, Err, Common, Opts, LaTeXFmtUtils, Expr.Utils) +%%] + +%%[1 hs import (ARule.Utils, ViewSel.Utils, Config( cfgStrSel, cfgFmFmtCmdAsc ), FmGam, RwExprGam, ECnstrGam) +%%] + +%%[1 hs import (AbsSyn.AbsSyn1, qualified AbsSyn.AbsSyn2 as AS2, qualified Main2AG as M2) +%%] + +%%[1 hs import (Utils, Admin, MkAdmin) +%%] + +------------------------------------------------------------------------- +-- Inclusion of split off parts +------------------------------------------------------------------------- + +%%[1 ag import ({AbsSyn/AbsSyn1AG}, {AbsSyn/CommonAG}, {FmGamAG}, {AS1/Misc}, {AS1/ViewDpd}, {AS1/SchemeDpd}, {AS1/Pretty}, {AS1/RlSel}) +%%] + +%%[1 ag import ({AS1/GenAS2}) +%%] + +%%[1 ag import ({Expr/AbsSynAG}, {Expr/IsRwAG}, {Expr/NmSAG}, {Expr/FmGamAG}, {Expr/PrettyPrintAG}, {Expr/SelfAG}, {Ty/AbsSynAG}, {Ty/SelfAG}) +%%] + +%%[1 ag + +------------------------------------------------------------------------- +-- Interfacing to AST +------------------------------------------------------------------------- + +WRAPPER AGItf + +------------------------------------------------------------------------- +-- Error +------------------------------------------------------------------------- + +ATTR AllAS1 AGItf [ | | errL USE {++} {[]}: {[Err]} ] + +SEM AGItf + | AGItf lhs . errL = @errDupSc ++ @errMutSc ++ @errBldDt ++ @errBldSc ++ @errDupRs ++ @errBldRs ++ @decls.errL + +SEM RExpr + | Judge lhs . errL = errFirst [@errSc,@errVwSc,@errJd,@eqns.errL] + +SEM RExprEqn + | Expr lhs . errL = errFirst [@errMt,@errJd] + +SEM Decl + | ShpJudge lhs . errL = errFirst [@errVwSc,@errUndefs] + | Scheme lhs . errL = @errDupVw ++ @decls.errL + | Rule lhs . errL = @errDupVw ++ @decls.errL + +------------------------------------------------------------------------- +-- Data/AST +------------------------------------------------------------------------- + +ATTR AllFldIntro [ seqNr: Int | | dtFldGam USE {`gamUnion`} {emptyGam}: DtFldGam ] + +SEM FldIntros + | Cons tl . seqNr = @lhs.seqNr + 1 + +SEM Decl + | DataASTAlt loc . seqNr = 1 + +SEM FldIntro + | Intro lhs . dtFldGam = gamSingleton @nm (DtFldInfo @nm @ty.self @lhs.seqNr) + +ATTR AllDecl [ | | dtAltGam USE {`gamUnion`} {emptyGam}: DtAltGam ] + +SEM Decl + | DataASTAlt lhs . dtAltGam = gamSingleton @nm (DtAltInfo @nm @ruleNm @mbBasedOnNm @fldIntros.dtFldGam) + +ATTR AllDecl [ | | vwDtGam USE {`gamUnion`} {emptyGam}: DtVwGam ] + +SEM Decl + | DataASTView lhs . vwDtGam = gamSingleton @nm (DtVwInfo @nm @decls.dtAltGam emptyGam) + +ATTR AllDecl [ | | gathDtGam USE {`gamUnion`} {emptyGam}: DtGam ] +ATTR AGItf [ | | dtInvGam: DtInvGam ] + +SEM Decl + | DataAST lhs . gathDtGam = gamSingleton @nm (DtInfo @nm @schemeNms @decls.vwDtGam) + +SEM AGItf + | AGItf loc . (dtGam,errBldDt) + = gamFoldWithKey + (\n i (g,e) + -> let (i',e') = bldDtInfo @vwDpdGr i + in (gamInsertShadow n i' g,e'++e) + ) + (@decls.gathDtGam,[]) + @decls.gathDtGam + . dtInvGam = dtGamInv @dtGam + +------------------------------------------------------------------------- +-- Attr +------------------------------------------------------------------------- + +{ +atGamUpdDirs :: ([AtDir] -> Bool) -> [AtDir] -> AtGam -> AtGam +atGamUpdDirs f d = gamMap (\i -> if f (atDirs i) then i {atDirs = d} else i) +} + +ATTR AllAttrIntroDecl AllDecl [ | | atGam USE {`gamUnion`} {emptyGam}: AtGam ] +ATTR AllAttrIntroDecl AllDecl [ | | atBldL USE {++} {[]}: {[ScAtBld]} ] +-- ATTR AllAttrIntro [ atDirs: {[AtDir]} | | ] + +SEM AttrIntro + | Intro loc . atGam = let (pd,pr) = partition (`Set.member` propsDir) @props + in gamSingleton @nm (AtInfo @nm pd pr @ty) + +SEM AttrIntroDecl + | Attrs loc . atGam = let t = const True + in atGamUpdDirs t [AtInh] @inhs.atGam `gamUnion` atGamUpdDirs t [AtInh,AtSyn] @inhsyns.atGam `gamUnion` atGamUpdDirs t [AtSyn] @syns.atGam + | AttrsProp loc . atGam = atGamUpdDirs null [AtInh,AtSyn] @intros.atGam + | AttrsProp Attrs lhs . atBldL = [ScAtBldDirect @atGam] + | Scheme lhs . atBldL = [ScAtBldScheme @nm @pos @renames.atRnmL] + +ATTR AllAttrRename [ | | atRnmL USE {++} {[]}: {[ScAtBldRename]} ] + +SEM AttrRename + | Rename lhs . atRnmL = [ScAtBldRename @nmNew @nmOld] + | EqualTo lhs . atRnmL = [ScAtBldEqualTo @nmLeft @nmRight] + +------------------------------------------------------------------------- +-- Externally declared identifiers +------------------------------------------------------------------------- + +ATTR AllDecl [ | | gathExtNmS USE {`Set.union`} {Set.empty}: {Set.Set Nm} ] + +SEM AGItf + | AGItf loc . extNmS = @decls.gathExtNmS + +SEM Decl + | Extern lhs . gathExtNmS = Set.fromList @nms + +------------------------------------------------------------------------- +-- View (related to scheme) +------------------------------------------------------------------------- + +ATTR AllDecl [ | | vwScGam USE {`gamUnion`} {emptyGam}: {VwScGam Expr} ] +ATTR AllDecl [ | | vwJdShpGam USE {`gamUnion`} {emptyGam}: {JdShpGam Expr} ] + +SEM Decl + | ScmView lhs . vwScGam = gamSingleton @nm (VwScInfo @nm @decls.vwJdShpGam @decls.atBldL [] emptyGam emptyGam @decls.explGam) + | ShpJudge lhs . vwJdShpGam = gamSingleton @fmKind (JdShpInfo @expr.self) + loc . cxStr = "judgement for view '" ++ show @lhs.viewNm ++ "' for scheme '" ++ show @lhs.scmNm ++ "'" + . (vwScInfo,errVwSc) + = case scVwGamLookup @lhs.scmNm @lhs.viewNm @lhs.scGam of + Just (_,i) -> (i,[]) + Nothing -> (emptyVwScInfo,[Err_UndefNm @pos @cxStr "view" [@lhs.viewNm]]) + . errUndefs = let nms = gamKeys (vwscFullAtGam @vwScInfo) \\ Set.toList @expr.nmS + in [] -- if null nms then [] else [Err_UndefNm @pos @cxStr "hole" nms] + | ShpDel lhs . vwJdShpGam = gamFromAssocs [ (k,JdShpDel) | k <- @fmKinds ] + +%%] + +------------------------------------------------------------------------- +-- Scheme, derived ones are expresses in terms of non-derived ones +------------------------------------------------------------------------- + +%%[1 hs +type MkDerivScInfo = (ScInfo Expr -> ScInfo Expr,ScGam Expr -> RsInfo Expr) +type DrvGam = Gam Nm [MkDerivScInfo] + +drvGamUnion :: DrvGam -> DrvGam -> DrvGam +drvGamUnion = gamUnionWith (++) +%%] + +%%[1 ag + +ATTR AllDecl [ drvGam: DrvGam | | gathDrvGam USE {`drvGamUnion`} {emptyGam}: DrvGam ] + +SEM Decl + | SchemeDeriv lhs . gathDrvGam = let mkListSc si + = siNw + where siNw = ScInfo @pos @nm @mbAGNm @scKind vGm + vGm + = gamMapWithKey + (\nVw vi + -> let mbNdNm = atGamNode (vwscAtGam vi) + (aGm,ndRenmG) + = case mbNdNm of + Just n -> (n `Map.delete` vwscAtGam vi,fmGamFromList [(n,Expr_Var @nm)]) + _ -> (vwscAtGam vi,emptyGam) + aNdGamNw + = if @firstVwNm == nVw + then gamSingleton @nm (AtInfo @nm [AtInh] [AtNode] (nmCapitalize @nm)) + else emptyGam + jdG = gamMap (\i -> i {jdshExpr = exprSubst @lhs.opts ndRenmG (jdshExpr i)}) (vwscJdShpGam vi) + in vi {vwscAtBldL = [ScAtBldDirect (aNdGamNw `gamUnion` aGm)], vwscJdShpGam = jdG} + ) + (scVwGam si) + mkNm n = n `nmStrApd` Nm "s" + vwSels = dgVertices @lhs.vwDpdGr + mkg :: Ord k => (v -> k) -> [v] -> Gam k v + mkg mkn l = gamFromAssocs [ (mkn i,i) | i <- l ] + mkRsInfo nl scGam + = RsInfo (@nm `nmApd` Nm "base") @pos @nm vwSels ("Rules for " ++ show @nm) (mkg rlNm [rl1]) + where rl1 + = RlInfo (@nm `nmApd` Nm "cons") emptySPos Nothing (Just "Cons") 0 (Just vwSels) (mkg vwrlNm [vw]) + where nHd = Nm "hd" + ndHd = @nm `nmApd` nHd + nTl = Nm "tl" + ndTl = @nm `nmApd` nTl + vw = mkVwRlInfo @firstVwNm emptySPos [RlJdBldDirect Set.empty (mkg reNm [j1,j2]) (mkg reNm [j3])] [] + j3 = REInfoJudge @nm @nm Set.empty Set.empty (mkg jaNm [a3]) False + a3 = mkJAInfo @nm e3 + e3 = mkExprApp (Expr_ChildOrder 0 (Expr_Var ndHd)) + [Expr_ChildOrder 1 (Expr_Var ndTl)] + n2 = maybe nl id $ scVwGamNodeAt nl @firstVwNm scGam + j2 = REInfoJudge nHd nl Set.empty Set.empty (mkg jaNm [a2]) False + a2 = mkJAInfo n2 e2 + e2 = Expr_Var ndHd + j1 = REInfoJudge nTl @nm Set.empty Set.empty (mkg jaNm [a1]) False + a1 = mkJAInfo @nm e1 + e1 = Expr_Var ndTl + in case @scDeriv of + ScList nl -> (gamSingleton nl [(mkListSc,mkRsInfo nl)]) + +SEM AGItf + | AGItf loc . drvGam = @decls.gathDrvGam + +------------------------------------------------------------------------- +-- Scheme +------------------------------------------------------------------------- + +ATTR AllDecl [ | | gathScGam USE {`gamUnion`} {emptyGam}: {ScGam Expr} ] +ATTR AllDecl AllRExpr AllRuleJudgeIntroDecl [ scGam: {ScGam Expr} | | ] +ATTR AGItf [ | | scGam: {ScGam Expr} ] + +SEM AGItf + | AGItf loc . (scGam,errBldSc) + = let r = foldr + (\sNm (scGam,scErrs) + -> let scInfo = gamLookupJust sNm scGam + drvScInfoL = maybe [] (\l -> map (($ scInfo) . fst) l) $ gamLookup sNm @drvGam + (ascL,errLL) = unzip [ ((scNm i',i'),e) | i <- (scInfo : drvScInfoL), let (i',e) = bldScInfo @vwDpdGr scGam i ] + in (gamFromAssocs ascL `gamUnionShadow` scGam,concat errLL ++ scErrs) + ) + (@decls.gathScGam,[]) + (dgTopSort @scDpdGr) + in r + +SEM Decl + | Scheme lhs . gathScGam = gamSingleton @nm (ScInfo @pos @nm @mbAGNm @scKind @decls.vwScGam) + +------------------------------------------------------------------------- +-- Rule +------------------------------------------------------------------------- + +ATTR AllAttrEqn [ | | jaGam USE {`gamUnion`} {emptyGam}: {JAGam Expr} ] + +SEM AttrEqn + | Eqn lhs . jaGam = gamSingleton @nm (mkJAInfo @nm @expr.self) + | Del lhs . jaGam = gamSingleton @nm (JAInfoDel @nm) + +ATTR RExprEqn [ vwScInfo: {VwScInfo Expr} pos: SPos cxStr: String schemeNm: Nm | | ] + +SEM RExprEqn + | Expr loc . (jdshExpr,errJd) + = gamTryLookups (Expr_Empty,[Err_NoJdSpec @lhs.pos @lhs.cxStr [@lhs.schemeNm]]) + (\i -> (jdshExpr i,[])) + [FmSpec,FmTeX,FmAll] (vwscJdShpGam @lhs.vwScInfo) + . mt = exprMatch (@lhs.opts {optMatchROpOpnd = False}) emptyGam @expr.self @jdshExpr + . errMt = if mtMatches @mt then [] else [Err_Match @lhs.pos @lhs.cxStr (pp @expr.self) (pp @jdshExpr)] + lhs . jaGam = fmGamToJaGam FmAll (mtFmGam @mt) `gamIntersection` vwscFullAtGam @lhs.vwScInfo + +ATTR AllRExpr [ | | reGam USE {`gamUnion`} {emptyGam}: {REGam Expr} ] + +SEM RExpr + | Judge eqns . pos = @pos + . schemeNm = @schemeNm + loc . nm = maybe (Nm (strUnd ++ show @lUniq)) id @mbRNm + . cxStr = "judgement for view '" ++ show @lhs.viewNm ++ "' for rule '" ++ show @lhs.ruleNm ++ "'" + . cxStr2 = @cxStr ++ " for scheme '" ++ show @schemeNm ++ "'" + . (scInfo,errSc) + = case gamLookup @schemeNm @lhs.scGam of + Just i -> (i,[]) + Nothing -> (emptyScInfo,[Err_UndefNm @pos @cxStr "scheme" [@schemeNm]]) + . (vwScInfo,errVwSc) + = case gamLookup @lhs.viewNm (scVwGam @scInfo) of + Just i -> (i,[]) + Nothing -> (emptyVwScInfo,[Err_UndefNm @pos @cxStr "view" [@lhs.viewNm]]) + . reInfo = REInfoJudge @nm @schemeNm Set.empty Set.empty @eqns.jaGam @isSmallExpr + . errJd = case gamKeys (@eqns.jaGam `gamDifference` vwscFullAtGam @vwScInfo) of + [] -> [] + ks -> [Err_NoXXFor @pos @cxStr2 "scheme hole definition" ks] + lhs . reGam = gamSingleton @nm @reInfo + | Del lhs . reGam = gamSingleton (head @nms) (REInfoDel @nms) + +------------------------------------------------------------------------- +-- Rules, names +------------------------------------------------------------------------- + +ATTR AllRExpr AllDecl AllRuleJudgeIntroDecl [ viewNm: Nm | | ] +ATTR AllRExpr AllDecl AllRuleJudgeIntroDecl [ ruleNm: Nm | | ] +ATTR AllDecl AllAttrIntroDecl AllRuleJudgeIntroDecl [ scmNm: Nm | | ] + +SEM Decl + | Rule loc . ruleNm = @nm + +SEM Decl + | Scheme loc . scmNm = @nm + +SEM Decl + | RulView ScmView loc . viewNm = @nm + +SEM AGItf + | AGItf decls . ruleNm = nmNone + . scmNm = nmNone + . viewNm = nmNone + +------------------------------------------------------------------------- +-- Rules, views for rule +------------------------------------------------------------------------- + +ATTR AllDecl [ | | vwRlGam USE {`gamUnion`} {emptyGam}: {VwRlGam Expr} ] + +SEM Decl + | RulView lhs . vwRlGam = gamSingleton @nm (mkVwRlInfo @nm @pos @jdIntros.jdBldL @group) + +ATTR AllDecl AllRuleJudgeIntroDecl [ | | jdBldL USE {++} {[]}: {[RlJdBld Expr]} ] + +SEM RuleJudgeIntro + | PrePost lhs . jdBldL = [RlJdBldDirect (Set.fromList @extNms) @pre.reGam @post.reGam] + | RulesetRule lhs . jdBldL = [RlJdBldFromRuleset @pos @rsNm @rlNm @schemeRnmL] + +------------------------------------------------------------------------- +-- Rules, individual rules for rule set +------------------------------------------------------------------------- + +ATTR AllDecl [ | | rlGam USE {`gamUnion`} {emptyGam}: {RlGam Expr} ] + +SEM Decl + | Rule lhs . rlGam = gamSingleton @nm (RlInfo @nm @pos @mbBasedOnNm @mbAGNm @lhs.rlSeqNr (fmap (viewSelNmS @lhs.vwDpdGr) @viewSel) @decls.vwRlGam) + +------------------------------------------------------------------------- +-- Rules, all rule sets +------------------------------------------------------------------------- + +ATTR AllDecl [ rsGam: {RsGam Expr} | | gathRsGam USE {`gamUnion`} {emptyGam}: {RsGam Expr} ] + +SEM AGItf + | AGItf loc . (rsGam,errBldRs) + = let r = foldr + (\sNm (rsGam,rsErrs) + -> let (rsGamBldL,errLL) + = unzip + $ map + (\rsInfo + -> let drvRsInfoL = maybe [] (\l -> map (($ @scGam) . snd) l) $ gamLookup sNm @drvGam + (blds,errs) + = unzip [ ((rsNm i',i'),e) | i <- (rsInfo : drvRsInfoL) + , let (i',e) = bldRsInfo @vwDpdGr @extNmS @lhs.opts @dtInvGam @scGam rsGam i + ] + in (gamFromAssocs blds,concat errs) + ) + $ [ i | i <- gamElems rsGam, rsInfoIsPlain i, rsScNm i == sNm ] + in (gamUnionsShadow rsGamBldL `gamUnionShadow` rsGam,concat errLL ++ rsErrs) + ) + (@decls.gathRsGam,[]) + (dgTopSort @scDpdGr) + in r + +SEM Decl + | Rules lhs . gathRsGam = gamSingleton @nm (RsInfo @nm @pos @schemeNm (viewSelNmS @lhs.vwDpdGr @viewSel) @info @decls.rlGam) + | RulesGroup lhs . gathRsGam = gamSingleton @nm (RsInfoGroup @nm @pos @schemeNm (viewSelNmS @lhs.vwDpdGr @viewSel) @info @rlNms) + +------------------------------------------------------------------------- +-- Formats, rewrites +------------------------------------------------------------------------- + +ATTR AllDecl [ | | gathFmGam USE {`fmGamUnion`} {emptyGam}: {FmGam Expr} ] +ATTR AGItf [ | | fmGam: {FmGam Expr} ] + +ATTR AllDecl [ | | gathRwGam USE {`rwGamUnion`} {emptyGam}: RwExprGam ] +ATTR AllDecl [ rwGam: RwExprGam | | ] +ATTR AGItf [ | | rwGam: RwExprGam ] + +SEM AGItf + | AGItf loc . fmGam = @decls.gathFmGam + `gamUnionShadow` + @lhs.fmGam + `gamUnionShadow` + fmGamFromList' FmFmtCmd [ (Nm f,Expr_Var (Nm t)) | (f,t) <- cfgFmFmtCmdAsc ] + . rwGam = @decls.gathRwGam + +SEM Decl + | Fmt lhs . (gathFmGam,gathRwGam) + = case @matchExpr.exprIsRw of + ExprIsRw n -> (emptyGam,rwSingleton n @fmKind @atIO (@matchExpr.self,@expr.self)) + ExprIsVar n -> (fmSingleton n @fmKind @expr.self,emptyGam) + ExprIsOther -> (emptyGam,emptyGam) + +SEM RExprEqn + | Expr loc . fmGam = emptyGam + . rwGam = emptyGam + . ecGam = emptyGam + +SEM AttrEqn + | Eqn loc . fmGam = emptyGam + . rwGam = emptyGam + . ecGam = emptyGam + +SEM Decl + | Fmt ShpJudge Explain + loc . fmGam = emptyGam + . rwGam = emptyGam + . ecGam = emptyGam + +------------------------------------------------------------------------- +-- Explanations +------------------------------------------------------------------------- + +ATTR AllDecl [ | | explGam USE {`gamUnion`} {emptyGam}: {ExplGam Expr} ] + +SEM Decl + | Explain lhs . explGam = gamSingleton (maybe nmNone id @mbNm) (ExplInfo @expr.self) + +------------------------------------------------------------------------- +-- Preambles +------------------------------------------------------------------------- + +ATTR AllDecl [ | | paGam USE {`gamUnion`} {emptyGam}: {FmKdGam String} ] + +SEM Decl + | Preamble lhs . paGam = gamSingleton @fmKind @preamble + +------------------------------------------------------------------------- +-- Error checks for duplicate names +------------------------------------------------------------------------- + +SEM AGItf + | AGItf loc . errDupRs = gamCheckDups emptySPos "toplevel" "ruleset/rulegroup" @decls.gathRsGam + . errDupSc = gamCheckDups emptySPos "toplevel" "scheme" @decls.gathScGam + +SEM Decl + | Rule loc . errDupVw = gamCheckDups @pos "rule" "view" @decls.vwRlGam + | Scheme loc . errDupVw = gamCheckDups @pos "scheme" "view" @decls.vwScGam + +------------------------------------------------------------------------- +-- Wrapping context (stack) +------------------------------------------------------------------------- + +{- +ATTR AllExpr [ wrKindStk: {[WrKind]} | | ] + +SEM Expr + | Wrap expr . wrKindStk = @wrKind : @lhs.wrKindStk + +SEM AGExprItf + | AGItf expr . wrKindStk = [WrNone] + +SEM Decl + | Fmt loc . wrKindStk = [WrNone] + +SEM RExprEqn + | Expr loc . wrKindStk = [WrNone] + +SEM AttrEqn + | Eqn loc . wrKindStk = [WrNone] + +SEM AExpr + | Expr loc . wrKindStk = [WrNone] + +SEM AEqn + | Err loc . wrKindStk = [WrNone] + +SEM Decl + | Fmt ShpJudge Explain + expr . wrKindStk = [WrNone] +-} + +%%] diff --git a/src/Main2AG.cag b/src/Main2AG.cag new file mode 100644 --- /dev/null +++ b/src/Main2AG.cag @@ -0,0 +1,44 @@ +------------------------------------------------------------------------- +-- Main for AG, pass 2 +------------------------------------------------------------------------- +%%[1 hs module (Main2AG) +%%] + +%%[1 hs import (Data.Maybe, Data.Char, Data.List, qualified Data.Set as Set, qualified Data.Map as Map, UHC.Util.Pretty, UHC.Util.PrettyUtils) +%%] + +%%[1 hs import (UHC.Util.Utils, Opts, Common, LaTeXFmtUtils, Expr.Utils, Ty.Utils, ARule.Utils, ViewSel.Utils) +%%] + +%%[1 hs import (Config( cfgStrSel ), FmGam, RwExprGam, ECnstrGam, AbsSyn.AbsSyn2) +%%] + +------------------------------------------------------------------------- +-- Inclusion of split off parts +------------------------------------------------------------------------- + +%%[1 ag import ({AbsSyn/AbsSyn2AG}, {AbsSyn/CommonAG}, {FmGamAG}, {AS2/Opts}, {AS2/Pretty}) +%%] + +%%[1 ag import ({Expr/AbsSynAG}, {Expr/PrettyPrintAG}, {Expr/SelfAG}, {Expr/FmGamAG}) +%%] + +%%[1 ag import ({ARule/AbsSynAG}, {ARule/PrettyPrintAG}, {ARule/SelfAG}, {ARule/FmGamAG}) +%%] + +------------------------------------------------------------------------- +-- Interfacing to AST +------------------------------------------------------------------------- + +%%[1 ag +WRAPPER AGItf +%%] + +%%[1 hs +ppAS2 :: Opts -> FmGam Expr -> Decls -> PP_Doc +ppAS2 o g r + = pp_Syn_AGItf r2 + where r1 = sem_AGItf (AGItf_AGItf r) + r2 = wrap_AGItf r1 + (Inh_AGItf {opts_Inh_AGItf = o, fmGam_Inh_AGItf = g}) +%%] diff --git a/src/MkAdmin.chs b/src/MkAdmin.chs new file mode 100644 --- /dev/null +++ b/src/MkAdmin.chs @@ -0,0 +1,507 @@ +-- $Id: Ruler.ag 231 2005-06-07 14:39:41Z atze $ + +------------------------------------------------------------------------- +-- Supporting functions for admin building +------------------------------------------------------------------------- + +%%[1 hs module (MkAdmin) +%%] + +%%[1 hs export (bldDtInfo, bldScInfo, bldRsInfo) +%%] + +%%[1 hs import (Data.Maybe, qualified Data.Set as Set, qualified Data.Map as Map, Data.List, UHC.Util.Nm, UHC.Util.Utils) +%%] + +%%[1 hs import (KeywParser( propsSynInhMp ), Opts, Err, Common, Expr.Utils, ARule.Utils( exprSubst ), ViewSel.Utils) +%%] + +%%[1 hs import (FmGam, Utils, Admin) +%%] + +------------------------------------------------------------------------- +-- Misc +------------------------------------------------------------------------- + +%%[1 hs +prevWRTDpd :: Nm -> DpdGr Nm -> Map.Map Nm v -> v -> v +prevWRTDpd n g m v + = maybeHd v (\n -> maybe v id . Map.lookup n $ m) (dgDpdsOn g n) +%%] + +------------------------------------------------------------------------- +-- Data/AST +------------------------------------------------------------------------- + +%%[1 hs +data BldDtState + = BldDtState + { bdDtAltGam :: DtAltGam + } + +emptyBldDtState + = BldDtState + { bdDtAltGam = emptyGam + } + +bldDtInfo :: DpdGr Nm -> DtInfo -> (DtInfo,[Err]) +bldDtInfo vwDpdGr dtInfo + = (dtInfo {dtVwGam = g},e) + where (g,_,e) + = foldr + (\vwNm (vdGam,bdMp,errs) + -> let bd = prevWRTDpd vwNm vwDpdGr bdMp emptyBldDtState + (vwDtInfo,bldErrs) + = case gamLookup vwNm vdGam of + Just i + -> (i {vdFullAltGam = g},[]) + where g = vdAltGam i `gamUnionShadow` bdDtAltGam bd + Nothing + -> (emptyDtVwInfo {vdNm = vwNm, vdFullAltGam = bdDtAltGam bd},[]) + bd' = bd {bdDtAltGam = vdFullAltGam vwDtInfo} + vdGam' = gamInsertShadow vwNm vwDtInfo vdGam + bdMp' = Map.insert vwNm bd' bdMp + in (vdGam', bdMp', bldErrs ++ errs) + ) + (dtVwGam dtInfo,Map.empty,[]) + (dgTopSort vwDpdGr) +%%] + +------------------------------------------------------------------------- +-- Scheme +------------------------------------------------------------------------- + +%%[1 hs +type ScmAtBldGam = Gam Nm [(Nm, AtInfo)] + +data BldScmState + = BldScmState + { bsAtGam :: ScmAtBldGam + , bsAtBldGam :: AtGam + , bsAtBldL :: [ScAtBld] + , bsJdShpGam :: JdShpGam Expr + , bsExGam :: ExplGam Expr + } + +emptyBldScmState + = BldScmState + { bsAtGam = emptyGam + , bsAtBldGam = emptyGam + , bsAtBldL = [] + , bsJdShpGam = emptyGam + , bsExGam = emptyGam + } + +bldNewScVw :: String -> ScGam Expr -> [ScAtBld] -> VwScInfo Expr -> (ScmAtBldGam,AtGam,[Err]) +bldNewScVw cx scGam prevAtBldL vw + = (gaNew,gbNew,bldErr) + where (gaNew,gbNew,bldErr) = mkAtGam (vwscAtBldL vw) gaPrv gbPrv + (gaPrv,gbPrv,_ ) = mkAtGam prevAtBldL emptyGam emptyGam + mkAtGam atBldL ga gb + = foldl + (\(ga,gb,e) b + -> case b of + ScAtBldDirect g + -> (mkPropForGam g2 `gamUnionShadow` ga,g2 `gamUnionShadow` gb,gamCheckDups emptySPos cx "hole" g ++ errChk ++ e) + where (g2,errChk) = chkUpdNewAts g gb + ScAtBldScheme frScNm pos rnL + -> case scVwGamLookup frScNm (vwscNm vw) scGam of + Just (frScInfo,frVwScInfo) + -> ( mkPropForGam g3 `gamUnionShadow` ga, g3 `gamUnionShadow` gb, errUndefHls ++ errChk ++ e ) + where errUndefHls + = if null undefNmL then [] else [Err_UndefNm pos ("use of scheme `" ++ show frScNm ++ "` for hole definition for " ++ cx) "hole" undefNmL] + (g2,undefNmL) + = sabrGamRename rnL (vwscFullAtBldGam frVwScInfo) + (g3,errChk) = chkUpdNewAts g2 gb + _ -> (ga,gb,[Err_UndefNm pos ("hole definition for " ++ cx) "scheme" [frScNm]] ++ e) + ) + (ga,gb,[]) + atBldL + chkUpdNewAts gNew g + = gamFold + (\i ge@(gNew,e) + -> case gamLookup (atNm i) g of + Just j + | isExternNew + -> (gamDelete (atNm i) gNew,e) + | otherwise + -> ge + where isExternNew = AtExtern `atHasProp` i + isExternOld = AtExtern `atHasProp` j + Nothing + -> ge + ) + (gNew,[]) + gNew + mkPropForGam + = gamMapWithKey + (\n a + -> case [AtThread] `atFilterProps` a of + (_:_) -> [ (ns,AtInfo ns [AtSyn] (atProps a) (atTy a)), (ni,AtInfo ni [AtInh] (atProps a) (atTy a)) ] + where ns = nmSetSuff n "syn" + ni = nmSetSuff n "inh" + _ -> [(n,a)] + ) + +bldScInfo :: DpdGr Nm -> ScGam Expr -> ScInfo Expr -> (ScInfo Expr,[Err]) +bldScInfo vwDpdGr scGam si@(ScInfo pos nm mbAGNm scKind vwScGam) + = (si {scVwGam = g},e) + where (g,_,e) + = foldr + (\nVw (vsg,bsMp,errs) + -> let bs = prevWRTDpd nVw vwDpdGr bsMp emptyBldScmState + cx = "scheme '" ++ show nm ++ "'" + (vw,bs',bldErrs) + = case gamLookup nVw vsg of + Just vw + -> ( vw + , bs + { bsAtGam = newAtGam + , bsAtBldGam = newBldGam + , bsAtBldL = bsAtBldL bs ++ vwscAtBldL vw + , bsJdShpGam = vwscJdShpGam vw `jdshpgUnionShadow` bsJdShpGam bs + , bsExGam = vwscExplGam vw `gamUnionShadow` bsExGam bs + } + , errDups ++ bldErr + ) + where (newAtGam,newBldGam,bldErr) = bldNewScVw cx scGam (bsAtBldL bs) vw + errDups = gamCheckDups pos cx "judgespec/use" (vwscJdShpGam vw) + ++ gamCheckDups pos cx "explanation" (vwscExplGam vw) + Nothing + -> ( vw + , bs + { bsAtGam = newAtGam + , bsAtBldGam = newBldGam + } + , bldErr + ) + where vw = emptyVwScInfo { vwscNm = nVw } + (newAtGam,newBldGam,bldErr) = bldNewScVw cx scGam (bsAtBldL bs) vw + vwag = gamFromAssocs . concat . gamElemsShadow $ bsAtGam bs' + bsMp' = Map.insert nVw bs' bsMp + in ( gamInsertShadow nVw (vw {vwscFullAtGam = vwag, vwscFullAtBldGam = bsAtBldGam bs', vwscJdShpGam = bsJdShpGam bs', vwscFullAtBldL = bsAtBldL bs', vwscExplGam = bsExGam bs'}) vsg + , bsMp' + , bldErrs ++ errs + ) + ) + (vwScGam,Map.empty,[]) + (dgTopSort vwDpdGr) +%%] + +------------------------------------------------------------------------- +-- Rule set building, util functions +------------------------------------------------------------------------- + +%%[1 hs +-- attr directions for names in gam +gamAtDirMp :: VwScInfo e -> Gam Nm v -> Map.Map Nm [AtDir] +gamAtDirMp vi g = gamToMap $ gamMapWithKey (\n _ -> maybe [] atDirs . gamLookup n . vwscFullAtGam $ vi) $ g + +-- split attr dir map into sets of syn/inh attrs +atDirMpSynInh :: Map.Map Nm [AtDir] -> (Set.Set Nm,Set.Set Nm) +atDirMpSynInh m + = Map.foldrWithKey (\n d (s,i) -> (if AtSyn `elem` d then Set.insert n s else s + ,if AtInh `elem` d then Set.insert n i else i)) + (Set.empty,Set.empty) m + +-- union of all judge attr defs in a set (of names with a specific direction) +jaGamUseInS :: JAGam e -> Set.Set Nm -> Set.Set Nm +jaGamUseInS g s = Set.unions [ jaNmS i | (n,i) <- gamAssocsShadow g, n `Set.member` s ] + +-- default attr gam of judgement, based on scheme +jaGamDflt :: Bool -> (Nm -> Expr) -> Nm -> Nm -> ScGam Expr -> JAGam Expr +jaGamDflt isPre mkE sn nVw scGam + = case scVwGamLookup sn nVw scGam of + Just (_,vi) -> gamMapWithKey (\n ai -> mkJAInfo n (mk n ai)) . vwscFullAtGam $ vi + Nothing -> emptyGam + where mk n ai + = if atIsExternUndef isPre ai + then Expr_Undefined + else mkE n + +-- determine sets if inh/syn var's +reGamUpdInOut :: Nm -> ScGam e -> REGam e -> REGam e +reGamUpdInOut nVw scGam pg + = gamMap + (\i -> + case i of + REInfoJudge _ sn _ _ jg _ | isJust mvi + -> i {reInNmS = jaGamUseInS jg aInhS, reOutNmS = jaGamUseInS jg aSynS} + where mvi = scVwGamLookup sn nVw scGam + aDirMp = gamAtDirMp (snd . maybe (panic "reGamUpdInOut") id $ mvi) jg + (aSynS,aInhS) = atDirMpSynInh aDirMp + _ -> i + ) + pg +%%] + +------------------------------------------------------------------------- +-- Judgements building, based on scheme description +------------------------------------------------------------------------- + +%%[1 hs +type JdBldInfo = (REInfo Expr,Maybe ([ScAtBldRename],Nm,Nm,VwScInfo Expr,VwScInfo Expr)) +type ScRnmMp = Map.Map Nm Nm +type RlJdBldInfo = (RlJdBld Expr,Maybe (VwRlInfo Expr,ScAtBld,Gam Nm JdBldInfo,Gam Nm JdBldInfo)) + +checkJdAndAtBldL :: SPos -> String -> ScGam Expr -> RsGam Expr -> Nm -> Nm -> [ScAtBld] -> [RlJdBld Expr] -> ([RlJdBldInfo],[Err]) +checkJdAndAtBldL pos cx scGam rsGam postScNm vwNm atBldL jdBldL + = (jdBldL2,errFirst [e1]) + where (jdBldL2,atBldL2,e1) + = foldr + (\b i@(jbL,abL,e) + -> case b of + RlJdBldFromRuleset pos rsNm rlNm scRnmL + -> ((b,Just (vwRlInfo,maybeHd emptyScAtBld id abRsL,preb,postb)):jbL,{-abRestL-}abL,errFirst [e1,e2,e3,e4++e5] ++ e) + where ((rsInfo,rlInfo,vwRlInfo),e1) + = maybe ((emptyRsInfo,emptyRlInfo,emptyVwRlInfo) + ,[Err_UndefNm pos (cx ++ " build item ruleset '" ++ show rsNm ++ "' rule '" ++ show rlNm ++ "'") ("ruleset+rule") [rsNm, rlNm]] + ) + (\i -> (i,[])) + $ rsRlVwGamLookup rsNm rlNm vwNm rsGam + scNm = rsScNm rsInfo + ((scInfo,vwScInfo),e2) + = maybe ((emptyScInfo,emptyVwScInfo),[Err_UndefNm pos cx "scheme" [scNm]]) (\i -> (i,[])) + $ scVwGamLookup scNm vwNm scGam + (abRsL,abRestL) + = partition (isOkSc scNm) abL + isOkSc scNm (ScAtBldScheme n _ _) = n == scNm + isOkSc scNm _ = False + e3 = if null abRsL then [Err_UndefNm pos cx "scheme build item" [scNm]] else [] + scRnmMp = Map.insert scNm postScNm $ Map.fromList [ (brNmFrom i,brNmTo i) | i <- scRnmL ] + gx jdg = gamFoldWithKey + (\jn i (g,e) + -> case reMbJd i of + Just i + -> (gamInsert jn (i,Just (b,scNmFr,scNmTo,vwScInfoFr,vwScInfoTo)) g,errFirst [e1,e2] ++ e) + where scNmFr = reScNm i + scNmTo = Map.findWithDefault scNmFr scNmFr scRnmMp + (e2,(_,vwScInfoTo)) + = maybe ([Err_UndefNm pos cx "scheme" [scNmTo]],(emptyScInfo,emptyVwScInfo)) ((,) []) + $ scVwGamLookup scNmTo vwNm scGam + vwScInfoFr = maybe emptyVwScInfo snd $ scVwGamLookup scNmFr vwNm scGam + b = concat $ map sabRenameL $ sabFilterScheme $ vwscFullAtBldL vwScInfoTo + _ -> (gamInsert jn (i,Nothing) g,e) + ) + (emptyGam,[]) + jdg + (preb ,e4) = gx (vwrlFullNoDfltPreGam vwRlInfo) + (postb,e5) = gx (vwrlFullNoDfltPostGam vwRlInfo) +{- +-} + _ -> ((b,Nothing):jbL,abL,e) + ) + ([],atBldL,[]) + jdBldL + +bldJdsFromRlBlds :: Nm -> Nm -> ScGam Expr -> [RlJdBldInfo] -> (REGam Expr,REGam Expr,[Err]) +bldJdsFromRlBlds scNm vwNm scGam rlBldInfoL + = r + where r@(preg,postg,e) + = foldl + (\g@(preg,postg,e) b + -> case b of + (RlJdBldFromRuleset _ rsNm rlNm scRnmL,Just (vwRlInfo,scAtBld,jprebg,jpostbg)) + -> (bpreg `reGamUnionShadow` preg,bpostg `reGamUnionShadow` postg,be++e) + where (bpreg,bpostg,be) + = case scAtBld of + ScAtBldScheme _ _ _ + -> (gamMap (upd2 True) jprebg,gamMap (upd2 False) jpostbg,[]) + where upd2 isPre (i,Just (rnL,scNmFr,scNmTo,vwScInfoFr,vwScInfoTo)) + = i {reScNm = scNmTo, reJAGam = fst $ sabrGamRename rnL $ fst $ chkUpdNewAts isPre mkg vwScInfoFr $ reJAGam i} + where mkg i = gamDelete (jaNm i) + upd2 isPre (i,_) + = i + (RlJdBldDirect _ dpreg dpostg,_) + -> (mkjg True dpreg `reGamUnionShadow` preg,mkjg False dpostg `reGamUnionShadow` postg,e) + where mkjg isPre + = gamMap mk + where mk i + = reUpdJAGam (fst $ chkUpdNewAts isPre mkg vwScInfo $ reJAGam i) i + where (_,vwScInfo) + = maybe (emptyScInfo,emptyVwScInfo) id $ scVwGamLookup (reScNm i) vwNm scGam + mkg i = gamInsertShadow (jaNm i) (i {jaExpr = Expr_Undefined}) + ) + (emptyGam,emptyGam,[]) + rlBldInfoL + chkUpdNewAts isPre mkg vwScInfo gNew + = gamFold + (\i ge@(gNew,e) + -> case gamLookup (jaNm i) g of + Just j + | atIsExternUndef isPre j + -> (mkg i gNew,e) + | otherwise + -> ge + Nothing + -> ge + ) + (gNew,[]) + gNew + where g = vwscAtGam vwScInfo + +bldDfltForJds :: Nm -> ScGam Expr -> (REGam Expr,REGam Expr) -> (REGam Expr,REGam Expr) +bldDfltForJds vwNm scGam (preg,postg) + = (mkjg True preg, mkjg False postg) + where mkag isPre sn = jaGamDflt isPre Expr_Var sn vwNm scGam + mkjg isPre = gamMap (\i -> i {reJAGam = mkag isPre (reScNm i)}) . reGamFilterOutDel +%%] + +------------------------------------------------------------------------- +-- Rule set building, top function +-- build views of a rule by extending each view along view order dependency +------------------------------------------------------------------------- + +%%[1 hs +data BldRlsState + = BldRlsState + { brPreGam :: REGam Expr + , brPostGam :: REGam Expr + , brJdBldL :: [RlJdBld Expr] + , brRlChGam :: RlChGam + } + +emptyBldRlsState + = BldRlsState + { brPreGam = emptyGam + , brPostGam = emptyGam + , brJdBldL = [] + , brRlChGam = emptyGam + } + +rlGamUpdVws :: String -> Opts -> DpdGr Nm -> Set.Set Nm -> DtInvGam -> ScGam Expr -> RsGam Expr -> RlGam Expr -> RsInfo Expr -> RlInfo Expr -> (RlInfo Expr,[Err]) +rlGamUpdVws cxRs opts vwDpdGr extNmS dtInvGam scGam rsGam rlGam rsInfo rlInfo + = let vwSel + = vs `Set.intersection` rsInclVwS rsInfo + where vs = case rlMbInclVwS rlInfo of + Just s -> s + _ -> case dtInvGamRlVwS (rsScNm rsInfo) (rlNm rlInfo) dtInvGam of + Just vs -- | optGenFM opts /= FmTeX + -> vs + _ -> dgVertices vwDpdGr + vwIsIncl n = n `Set.member` vwSel + doMarkChngForVw + = case optMbMarkChange opts of + Just vs + -> \vw -> (vw `Set.member` vs',dgIsFirst vwDpdGr vw vs') + where vs' = viewSelsNmS vwDpdGr vs `Set.intersection` vwSel + _ -> const (False,False) + (g,_,eg,errs) + = foldr + (\nVw (vrg,brMp,errg,errs) + -> let -- info from previous view (in view hierarchy) + br = prevWRTDpd nVw vwDpdGr brMp emptyBldRlsState + (vwRlInfo,vwHasDefs) + = case gamLookup nVw vrg of + Just i -> (i,True) + _ -> (emptyVwRlInfo {vwrlNm=nVw},False) + vrgOfVwRlInfo = gamLookup nVw . rlVwGam + (doMarkChng,isFstMarkChng) = doMarkChngForVw nVw + + -- + revRlOnL = rlVwRlOnL dtInvGam rlGam (rsScNm rsInfo) nVw rlInfo + (initBldL,rlJdBldOnL) + = case revRlOnL of + (i:_) | dgIsFirst vwDpdGr nVw vwSel + -> ([RlJdBldDirect Set.empty (vwrlFullNoDfltPreGam i) (vwrlFullNoDfltPostGam i)],[]) + _ -> (brJdBldL br,b) + where b = concat $ map vwrlJdBldL $ reverse $ revRlOnL +{- + vwIsFirst = dgIsFirst vwDpdGr nVw vwSel + rlJdBldOnL rlInfo + = case maybe Nothing (\n -> gamLookup n rlGam) (mbOnNm rlInfo) of + Just i -> case gamLookup nVw (rlVwGam i) of + Just j | vwIsFirst -> [RlJdBldDirect Set.empty (vwrlFullPreGam j) (vwrlFullPostGam j)] + | otherwise -> rlJdBldOnL i ++ vwrlJdBldL j + _ -> [] + _ -> [] + mbOnNm rlInfo = dtInvGamRlMbOn dtInvGam rlInfo (rsScNm rsInfo) nVw +-} + rlJdBldL = initBldL ++ rlJdBldOnL ++ vwrlJdBldL vwRlInfo + (rlJdBldInfoL,errChkBldL) = checkJdAndAtBldL (vwrlPos vwRlInfo) cx scGam rsGam (rsScNm rsInfo) nVw (vwscFullAtBldL vwScInfo) rlJdBldL + (pregBld,postgBld,errBldL) = bldJdsFromRlBlds (rsScNm rsInfo) nVw scGam rlJdBldInfoL + (pregBldDflt,postgBldDflt) = bldDfltForJds nVw scGam (pregBld,postgBld) + pregBldFull = pregBld `reGamUnionShadow` pregBldDflt + postgBldFull = postgBld `reGamUnionShadow` postgBldDflt + + -- rule info + (scInfo,vwScInfo) = maybe (emptyScInfo,emptyVwScInfo) id $ scVwGamLookup (rsScNm rsInfo) nVw scGam + + -- updating pre/post judgements + (preg',postg') = (reGamFilterOutDel pregBldFull,reGamFilterOutDel postgBldFull) + + -- changes + vwRlChs + = gamMapWithKey (\jn ji -> gamMapWithKey (\an _ -> RlChInfo jn an) (maybe emptyGam id $ reMbJAGam ji)) + $ (preg' `gamUnionShadow` postg') `reGamJAGamDifferenceOnExpr` (brPreGam br `gamUnionShadow` brPostGam br) + vwRlChsWtPrev = vwRlChs `rcGamUnionShadow` brRlChGam br + prevVwRlChs' = if doMarkChng then emptyGam else vwRlChsWtPrev + + -- updating the view + vwRlInfo2 + = vwRlInfo + { vwrlFullPreGam = reGamUpdInOut nVw scGam preg' + , vwrlFullPostGam = reGamUpdInOut nVw scGam postg' + , vwrlFullNoDfltPreGam = pregBld + , vwrlFullNoDfltPostGam = postgBld + , vwrlMbChGam = if doMarkChng && not isFstMarkChng then Just vwRlChsWtPrev else Nothing + , vwrlJdBldOnAL = rlJdBldOnL, vwrlJdBldOnBL = initBldL + } + vwRlInfo3 = vwrlDelEmptyJd vwRlInfo2 + vwRlInfo4 = vwRlInfo3 {vwrlPreScc = vwrlScc vwRlInfo3} + + -- errors + cx = cxRs ++ " view '" ++ show nVw ++ "' for rule '" ++ show (rlNm rlInfo) ++ "'" + errVwNotSel = if not vwHasDefs || vwIsIncl nVw then [] else [Err_NotInSel (vwrlPos vwRlInfo) cx (Set.toList vwSel)] + vwUndefs = vwrlUndefs vwRlInfo3 `Set.difference` (vwrlExtNmS vwRlInfo `Set.union` extNmS) + errUndefs = if Set.null vwUndefs then [] else [Err_UndefNm (rlPos rlInfo) cx "identifier" (Set.toList vwUndefs)] + errDups = gamCheckDups (rlPos rlInfo) cx "judgement" (vwrlPreGam vwRlInfo `gamUnion` vwrlPostGam vwRlInfo) + postOfScG = gamFilter (\i -> reScNm i == rsScNm rsInfo) (vwrlFullPostGam vwRlInfo4) + errPost + = if (not . gamIsEmpty $ vwrlFullPostGam vwRlInfo4) && gamIsEmpty postOfScG && scKind scInfo == ScJudge + then [Err_RlPost (rlPos rlInfo) cx (rsScNm rsInfo)] + else [] + errTr = [] + -- [mkTr (ppBracketsCommas [rsScNm rsInfo,rlNm rlInfo,nVw]) (pp (mbOnNm rlInfo))] + -- [mkTr (ppBracketsCommas [rsScNm rsInfo,rlNm rlInfo,nVw]) (ppBracketsCommasV rlJdBldL >-< ppGam pregBld)] + -- [mkTr (ppBracketsCommas [rsScNm rsInfo,rlNm rlInfo,nVw]) (ppBracketsCommas $ Set.toList $ vwSel)] + errsVw = errFirst [errPost,errDups,errUndefs,errChkBldL,errBldL] ++ errTr + errsOther = errVwNotSel + + -- next build state + br' = br {brPreGam = preg', brPostGam = postg', brJdBldL = rlJdBldL, brRlChGam = prevVwRlChs'} + + in ( if vrwlIsEmpty vwRlInfo4 then gamDelete nVw vrg else gamInsertShadow nVw vwRlInfo4 vrg + , Map.insert nVw br' brMp + , if null errsVw then errg else gamInsertShadow nVw errsVw errg + , errsOther ++ errs + ) + ) + (rlVwGam rlInfo,Map.empty,emptyGam,[]) + (dgTopSort vwDpdGr) + errsG = concat . gamElemsShadow . gamFilterWithKey (\n _ -> vwIsIncl n) $ eg + in (rlInfo { rlVwGam = gamFilterWithKey (\n _ -> vwIsIncl n) g, rlMbInclVwS = Just vwSel },errFirst [errs,errsG]) + + +bldRsInfo :: DpdGr Nm -> Set.Set Nm -> Opts -> DtInvGam -> ScGam Expr -> RsGam Expr -> RsInfo Expr -> (RsInfo Expr,[Err]) +bldRsInfo vwDpdGr extNmS opts dtInvGam scGam rsGam rsInfo@(RsInfo nm pos schemeNm _ info rlGam) + = (rsInfo {rsRlGam = g},mutErrs ++ errTr ++ errs) + where (g,errs) + = foldr + (\rNm (rlGam,errs) + -> let (rlInfo,errs') + = rlGamUpdVws cx opts vwDpdGr extNmS dtInvGam scGam rsGam rlGam rsInfo (maybe (panic "bldRsInfo") id . gamLookup rNm $ rlGam) + in (gamInsertShadow rNm rlInfo rlGam,errs' ++ errs) + ) + (rlGam,[]) + (dgTopSort rlDpdGr) + errTr = [] -- [mkTr (ppBracketsCommas [nm]) (pp rlDpdGr)] + rlDpdGr + = mkDpdGrFromAssocWithMissing misL dpdL + where -- dpdL = [ (rlNm i,onNm) | i <- gamElemsShadow rlGam, onNm <- maybeToList (rlMbOnNm i) ] + dpdL = [ (rlNm i,onNm) | i <- gamElemsShadow rlGam, nVw <- gamKeys (rlVwGam i), onNm <- maybeToList (dtInvGamRlMbOn dtInvGam i (rsScNm rsInfo) nVw) ] + misL = gamKeys rlGam \\ map fst dpdL + cx = "ruleset '" ++ show (rsNm rsInfo) ++ "'" + mutErrs = dgCheckSCCMutuals (Err_MutDpds pos cx "rule") rlDpdGr + +%%] diff --git a/src/NmParser.chs b/src/NmParser.chs new file mode 100644 --- /dev/null +++ b/src/NmParser.chs @@ -0,0 +1,54 @@ +------------------------------------------------------------------------- +-- Nm parser +------------------------------------------------------------------------- + +%%[1 hs module (NmParser) +%%] + +%%[1 hs export (NmSPos, pNmDotSym, pNmSym, pNmDotted, pNmDottedSPos, pNmVw, pNmVwSPos, pNm, pNmSPos) +%%] + +%%[1 hs import (UU.Parsing, Scanner, UHC.Util.ParseUtils, UHC.Util.Nm, SelParser, KeywParser) +%%] + +------------------------------------------------------------------------- +-- Parser +------------------------------------------------------------------------- + +%%[1 hs +type NmSPos = (Nm,SPos) + +pNmDotSymSPos :: (IsParser p Token) => p String -> p (NmSPos -> NmSPos) +pNmDotSymSPos pSymStr + = pSel (id,(\(n1,p) n2 -> (n1 `NmSel` n2,p)),Just) (pN,pMb pN) + where pN = pNmStrI <|> pSymStr + +pNmDotSym :: (IsParser p Token) => p String -> p (Nm -> Nm) +pNmDotSym pSymStr + = pSel (id,NmSel,Just) (pN,pMb pN) + where pN = pNmStrI <|> pSymStr + +pNmBaseSelSPos :: (IsParser p Token) => (p SPos,p String) -> p NmSPos +pNmBaseSelSPos (pN,pS) = ((\sp@(s,p) -> (Nm s,sp)) <$> pN) <**> pNmDotSymSPos pS + +pNmSym :: (IsParser p Token) => (p String,p String) -> p Nm +pNmSym (pN,pS) = (Nm <$> pN) <**> pNmDotSym pS + +pNmVwSPos :: (IsParser p Token) => p NmSPos +pNmVwSPos = pNmBaseSelSPos (pNmStrISPos,pSymStr) + +pNmVw :: (IsParser p Token) => p Nm +pNmVw = fst <$> pNmVwSPos + +pNmDottedSPos :: (IsParser p Token) => p String -> p NmSPos +pNmDottedSPos pSymStr = pNmBaseSelSPos (pNmStrSPos,pSymStr) + +pNmDotted :: (IsParser p Token) => p String -> p Nm +pNmDotted pSymStr = fst <$> pNmDottedSPos pSymStr + +pNmSPos :: (IsParser p Token) => p NmSPos +pNmSPos = pNmBaseSelSPos (pNmStrSPos,pSymStr) + +pNm :: (IsParser p Token) => p Nm +pNm = fst <$> pNmSPos +%%] diff --git a/src/Opts.chs b/src/Opts.chs new file mode 100644 --- /dev/null +++ b/src/Opts.chs @@ -0,0 +1,154 @@ +------------------------------------------------------------------------- +-- Options +------------------------------------------------------------------------- + +%%[1 hs module (Opts) +%%] + +%%[1 hs export (Opts(..), defaultOpts, cmdLineOpts) +%%] + +%%[1 hs import (System.Console.GetOpt, UHC.Util.ParseUtils, Common, ViewSel.ViewSel, ViewSel.Self, ViewSel.Parser) +%%] + +%%[1 hs + +------------------------------------------------------------------------- +-- Options +------------------------------------------------------------------------- + +data Opts + = Opts + { optGenFM :: FmKind + , optGenExpl :: Bool + , optGenV2 :: Bool + , optGenAGAttr :: Bool + , optGenAGData :: Bool + , optDot2Dash :: Bool + , optPreamble :: Bool + , optAtDir :: AtDir -- used internally only + , optSubstFullNm :: Bool -- used internally only + , optSubstOnce :: Bool -- used internally only + , optMatchROpOpnd :: Bool -- used internally only + , optHelp :: Bool + , optDebug :: Bool + , optVersion :: Bool + , optSvnVersion :: Bool + , optFragWrap :: Bool + , optAGCopyElim :: Bool + , optMbMarkChange :: Maybe ViewSels + , optMbRlSel :: Maybe RlSel + , optBaseNm :: String + , optSearchPath :: [String] + , optDefs :: [(String,String)] + } + deriving Show + +defaultOpts + = Opts + { optGenFM = FmAll + , optGenExpl = False + , optGenV2 = False + , optGenAGAttr = False + , optGenAGData = False + , optDot2Dash = False + , optPreamble = True + , optAtDir = AtInOut + , optSubstFullNm = True + , optSubstOnce = False + , optMatchROpOpnd = True + , optHelp = False + , optDebug = False + , optVersion = False + , optSvnVersion = False + , optFragWrap = False + , optAGCopyElim = True + , optMbMarkChange = Nothing + , optMbRlSel = Nothing + , optBaseNm = rulesCmdPre + , optSearchPath = [] + , optDefs = [] + } + +cmdLineOpts + = [ Option "a" ["ag"] (NoArg oGenAG) + "generate code for AG, default=no" + , Option "" ["ATTR"] (NoArg oGenAGAttr) + "generate ATTR defs (for AG), default=no" + , Option "b" ["base"] (ReqArg oBase "") + "base name, default = 'rules'" + , Option "c" ["markchanges"] (OptArg oMarkCh "") + "mark changes between specified views (with --lhs2tex)" + -- "mark changes between specified views (in combi with --lhs2tex, =*||-)" + , Option "" ["copyelim"] (OptArg oCopyElim "yes|no") + "perform AG copy elimination, default=yes" + , Option "" ["DATA"] (NoArg oGenAGData) + "generate DATA defs (for AG, HS), default=no" + , Option "d" ["debug"] (NoArg oDebug) + "output debugging info" + , Option "D" ["def"] (ReqArg oDef "key[=|:]value") + "define key/value" + , Option "" ["dot2dash"] (NoArg oDot2Dash) + "change '.' in rule names to '-', default=no" + , Option "" ["explain"] (NoArg oGenExpl) + "generate explanation (for scheme's), default=no" + , Option "" ["help"] (NoArg oHelp) + "output this help" + , Option "h" ["hs"] (NoArg oGenHS) + "generate code for Haskell, default=no (in development)" + , Option "l" ["lhs2tex"] (NoArg oGenLhs2tex) + "generate code for lhs2tex, default=no" + , Option "P" ["path"] (ReqArg oPath "") + "search path, default empty" + , Option "" ["preamble"] (OptArg oPreamble "yes|no") + "include preamble, default=yes" + , Option "s" ["selrule"] (OptArg oRlSel "") + "select rules by specifying view(s), ruleset(s) and rule(s)" + -- "select rules by specifying view(s), ruleset(s) and rule(s), =(*||-).(*|).(*|)" + , Option "" ["svn-version"] (NoArg oSvnVersion) + "print svn version info" +{- + , Option "" ["as2"] (NoArg oGenAS2) + "generate code for AS2 (under development, internal restructure), default=no" +-} + , Option "" ["v1"] (NoArg oGenV1) + "current version of whatever is under development, default=yes" + , Option "" ["v2"] (NoArg oGenV2) + "next version of whatever is under development, default=no" + , Option "" ["version"] (NoArg oVersion) + "print version info" + , Option "w" ["wrapshuffle"] (NoArg oFragWrap) + "wrap (AG|explanation) in fragments for processing by shuffle" + ] + where oGenLhs2tex o = o {optGenFM = FmTeX} + oGenAG o = o {optGenFM = FmAG} + oGenHS o = o {optGenFM = FmHS} +{- + oGenAS2 o = o {optGenFM = FmAS2 (optGenFM o)} +-} + oGenV2 o = o {optGenV2 = True} + oGenV1 o = o {optGenV2 = False} + oGenExpl o = o {optGenExpl = True} + oGenAGAttr o = o {optGenAGAttr = True} + oGenAGData o = o {optGenAGData = True} + oDot2Dash o = o {optDot2Dash = True} + oPreamble ms o = yesno (\f o -> o {optPreamble = f}) ms o + oCopyElim ms o = yesno (\f o -> o {optAGCopyElim = f}) ms o + oHelp o = o {optHelp = True} + oFragWrap o = o {optFragWrap = True} + oDebug o = o {optDebug = True} + oVersion o = o {optVersion = True} + oSvnVersion o = o {optSvnVersion = True} + oBase s o = o {optBaseNm = s} + oPath s o = o {optSearchPath = searchPathFromString s} + oDef s o = case break (\c -> c == ':' || c == '=') s of + (s1,(_:s2)) -> o {optDefs = (s1,s2) : optDefs o} + _ -> o + oMarkCh ms o = o {optMbMarkChange = fmap (viewSelsSelfT . fst . parseToResMsgs pViewSels . mkScan "") ms} + oRlSel ms o = o {optMbRlSel = fmap (rlSelSelfT . fst . parseToResMsgs pRlSel . mkScan "") ms} + yesno updO ms o = case ms of + Just "yes" -> updO True o + Just "no" -> updO False o + _ -> o + +%%] diff --git a/src/Parser.chs b/src/Parser.chs new file mode 100644 --- /dev/null +++ b/src/Parser.chs @@ -0,0 +1,267 @@ +------------------------------------------------------------------------- +-- Ruler parser +------------------------------------------------------------------------- + +%%[1 hs module (Parser) +%%] + +%%[1 hs export (pAGItf) +%%] + +%%[1 hs import (qualified Data.Set as Set, qualified Data.Map as Map, UU.Parsing) +%%] + +%%[1 hs import (UU.Parsing.Offside, UU.Scanner.Position( initPos, Pos, Position(..) )) +%%] + +%%[1 hs import (UU.Scanner.GenToken, Scanner, UHC.Util.ParseUtils, UHC.Util.ScanUtils) +%%] + +%%[1 hs import (NmParser, SelParser, KeywParser, ViewSel.ViewSel, ViewSel.Parser) +%%] + +%%[1 hs import (Common, AbsSyn.AbsSyn1) +%%] + +%%[1 hs + +------------------------------------------------------------------------- +-- Parser +------------------------------------------------------------------------- + +type RulerParser ep + = (IsParser (OffsideParser i o Token p) Token,InputState i Token p, OutputState o, Position p) + => OffsideParser i o Token p ep +{- +type RulerParser ep + = (IsParser (OffsideParser i o Token p) Token,InputState i Token p, OutputState o, Position p) + => OffsideParser i o Token p ep +-} + +type MkConAppAlg t = (String -> t,t -> t -> t,t -> t) + +mkApp :: MkConAppAlg t -> [t] -> t +mkApp (_,app,top) ts + = case ts of + [t] -> t + _ -> top t + where t = foldl1 app ts + +pAGItf :: (IsParser p Token) => p AGItf -- RulerParser AGItf +pAGItf + = let alg = (undefined,Expr_App,Expr_AppTop) + pAGItf = AGItf_AGItf <$> pTopDecls' pDeclGlob + pLay p = pBlock pOParen (pKey "|") pCParen p + pLay1 p = pBlock1 pOParen (pKey "|") pCParen p + pLay2Sep open sep close sepElt p + = pOffside open close explicit implicit + where sep' = () <$ sep + elems s = (,) <$> l <* s <* sepElt <* s <*> l + where l = pListSep s p + -- sp = pList s + explicit = elems sep' + implicit = elems (sep' <|> pSeparator) +{- +pBlock open sep close p = pOffside open close explicit implicit + where elem = (:) <$> p `opt` id + sep' = () <$ sep + elems s = ($[]) <$> pFoldr1Sep ((.),id) s elem + explicit = elems sep' + implicit = elems (sep' <|> pSeparator) + +pBlock1 open sep close p = pOffside open close explicit implicit + where sep' = () <$ sep + elems s = pList s *> pList1Sep (pList1 s) p <* pList s + explicit = elems sep' + implicit = elems (sep' <|> pSeparator) + pTopDecls' pD = pLay pD +-} + pTopDecls' pD = pList pD + pDecls' pD = pList pD + pDecls1' pD = pList1 pD + pDeclRule = (\(n,p) mn s mag d -> Decl_Rule p n mn s mag d) + <$ pKeySPos "rule" <*> pNmSPos + <*> pMb (pKey ":" *> pNm) + <*> pMbViewSel' + <*> pMbString + <* pKey "=" <*> (pDeclRuleDflt <|> pDecls1' pDeclRulView) + pDeclRuleDflt = (\d -> [Decl_RulView emptySPos nmNone d []]) + <$> pRuleJudgeIntros + pDeclRulView = (\(v,p) d -> Decl_RulView p v d) + <$ pKey "view" <*> pNmVwSPos + <* pKey "=" <*> pRuleJudgeIntros + <*> opt (pKey "group" *> pListSep pComma (pList1 pNm)) [] +{- + mkDeclRulView p v pre post order + = Decl_RulView p v [RuleJudgeIntro_PrePost pre post] order + pRuleViewJudges = (,) <$> pRExprs <* sep <*> pRExprs + <|> pKey "judges" *> pLay2Sep pOParen (pKey "|") pCParen sep pRExprBase -- experimental + where pRExprs = pList pRExpr + -- pRExprsLay = pLay pRExprBase + sep = pKey "-" <|> pKey "---" +-} + pRuleJudgeIntroPrePost + = RuleJudgeIntro_PrePost <$> (pKey "extern" *> pList1 pNmDir `opt` []) <*> pRExprs <* sep <*> pRExprs + where pRExprs = pList pRExpr + -- pRExprsLay = pLay pRExprBase + sep = pKey "-" <|> pKey "---" + pRuleJudgeIntros = (:[]) <$> pRuleJudgeIntroPrePost + <|> pList1Sep (pKey "|") (pRuleJudgeIntro <|> pParens pRuleJudgeIntroPrePost) + pRuleJudgeIntro = (\(rsn,p) rln -> RuleJudgeIntro_RulesetRule p rsn rln) + <$ pKey "ruleset" <*> pNmSPos <* pKey "rule" <*> pNm + <*> (pParens_pCommas (BldRename <$ pKey "scheme" <*> pNm <* pKey "->" <*> pNm) `opt` []) + pDeclScm = Decl_ScmView <$ pKey "view" <*> pNmVw + <* pKey "=" <*> pDeclsScmView + pDeclScmDflt = (\v -> [Decl_ScmView nmNone v]) + <$> pDeclsScmView + pDeclScmView = pKeySPos "judgespec" + <**> ( (\e p -> Decl_ShpJudge p FmSpec e) <$> pExprLF + ) + <|> pKeySPos "judgeshape" <**> pShp pFmKd3WithDflt pFmKd3 + <|> pKeySPos "judgeuse" <**> pShp pFmKd2 pFmKd2 + <|> Decl_Attr <$ (pKey "hole" <|> pKey "holes") + <*> pAttrIntroDecls + <|> Decl_Explain <$ pKey "explain" <*> pMb (pNmDir <* pKey "=") <*> pParens pExprExplain + where pShp pFmAdd pFmDel + = ( (\k e p -> Decl_ShpJudge p k e) <$> pFmAdd <*> pExprLF + <|> (flip Decl_ShpDel) <$ pKey "-" <*> pList1 pFmDel + ) + pAttrIntroDecl = pKey "[" + *> pAttrIntros + <**> ( (\is s i -> AttrIntroDecl_Attrs i is s) + <$ pKey "|" <*> pAttrIntros <* pKey "|" <*> pAttrIntros + `opt` AttrIntroDecl_AttrsProp + ) + <* pKey "]" + <|> (\(s,p) r -> AttrIntroDecl_Scheme p s r) + <$ pKey "scheme" <*> pNmSPos <*> (pAttrRenames `opt` []) + pAttrIntroDecls = pList1Sep (pKey "|") pAttrIntroDecl + pAttrRename = pNmSPos + <**> ( (\o (n,p) -> AttrRename_Rename p n o) <$ pKey ":=" <*> pNm + <|> (\r (l,p) -> AttrRename_EqualTo p l r) <$ pKey "=" <*> pNm + ) + pAttrRenames = pParens_pCommas pAttrRename + pDeclsScmView = pDecls1' pDeclScmView + pDeclDataASTView = (\(n,p) d -> Decl_DataASTView p n d) + <$ pKey "view" <*> pNmSPos <* kIsBar <*> pDeclDataASTAlts + pDeclDataASTViewDflt= (\d -> [Decl_DataASTView emptySPos nmNone d]) + <$> pDeclDataASTAlts + pDeclDataASTAlts = pList1Sep (pKey "|") pDeclDataASTAlt + pDeclDataASTAlt = (\(n,p) (rn,mbon) d -> Decl_DataASTAlt p n rn mbon d) + <$> pNmSPos <*> pBracks (pNm <+> pMb (pKey ":" *> pNm)) <*> pFldIntros + pDeclGlob = pDeclGlobScheme + <|> Decl_Fmt <$ (pKey "format" <|> pKey "rewrite") + <*> pFmKd2WithDflt + <*> pAtIO + <*> pExpr + <* pKey "=" <*> pExpr + <|> (\(n,p) sn mvs s d -> Decl_Rules p n sn mvs s d) + <$ (pKey "rules" <|> pKey "ruleset") + <*> pNmSPos + <* pKey "scheme" <*> pNm <*> pMbViewSel <*> pString + <* pKey "=" <*> pDecls' pDeclRule + <|> (\(n,p) sn mvs s r -> Decl_RulesGroup p n sn mvs s r) + <$ pKey "rulesgroup" + <*> pNmSPos + <* pKey "scheme" <*> pNm <*> pMbViewSel <*> pString + <* pKey "=" <*> pList1 ((,) <$ pKey "rule" <*> pNm <*> pNm) + <|> Decl_ViewHierarchy <$ pKey "viewhierarchy" + <* pKey "=" <*> pList1Sep pComma (pList1Sep (pKey "<") pNmVw) + <|> Decl_Preamble <$ pKey "preamble" <*> pFmKd2WithDflt <*> pString + <|> Decl_Extern <$ (pKey "extern" <|> pKey "external") + <*> pList1 pNm + <|> (\(n,p) sn d -> Decl_DataAST p n sn d) + <$ pKey "data" <*> pNmSPos <*> pBracks_pCommas pNm + <*> (pDeclDataASTViewDflt <|> pDecls' pDeclDataASTView) + <|> (\(n,p) -> Decl_Include p n) + <$ pKey "include" <*> pNmSPos + pDeclGlobScheme = (ScJudge <$ pKey "scheme" <|> ScRelation <$ pKey "relation") + <**> (pNmSPos + <**> ( (\d (ms,ds) (n,p) k -> Decl_SchemeDeriv p k n d ms ds) + <$ pKey ":" <*> pScDeriv <*> pTl2 + <|> (\(ms,ds) (n,p) k -> Decl_Scheme p k n ms ds) + <$> pTl1 + ) + ) + where pTl1 = (,) <$> pMbString <*> pDs + pDs = pKey "=" *> (pDeclScmDflt <|> pDecls1' pDeclScm) + pTl2 = (,) <$> pMbString <*> (pMaybe [] id pDs) + pScDeriv = ScList <$ pKey "[" <*> pNm <* pKey "]" + pMbViewSel' = pMaybe Nothing Just (pKey "viewsel" *> pViewSel) + pMbViewSel = pMaybe ViewSel_All id (pKey "viewsel" *> pViewSel) + pFmKd2WithDflt = pMaybe FmAll id pFmKd2 + pFmKd3WithDflt = pMaybe FmAll id pFmKd3 + pFmKd2 = FmTeX <$ pKey "tex" <|> FmAG <$ pKey "ag" <|> FmFmtCmd <$ pKey "fmtcmd" + pFmKd3 = FmSpec <$ pKey "spec" <|> pFmKd2 + pAtIO = pMaybe AtInOut id (AtIn <$ pKey "def" <|> AtOut <$ pKey "use") + pNmBase = Nm <$> pNmStr + pNmDir = pNmDotted (pSymStr <|> pAnyKey pKey keywordsTextDir) + -- pNmDirSPos = pNmDottedSPos (pSymStr <|> pAnyKey pKey keywordsTextDir) + pNmC = Nm <$> pConid + pNmV = Nm <$> pVarid + pSym = Nm <$> pSymStr + pRExpr = pKey "judge" *> pRExprBase + pRExprBase = (\msmall mrnp (n,p) e + -> let (mrn,p') = maybe (Nothing,p) (\(n,p) -> (Just n,p)) mrnp + small = maybe False (const True) msmall + in RExpr_Judge p' mrn n e small + ) + <$> pMb (pKey "*") <*> pMb (pNmSPos <* pKey ":") <*> pNmSPos <*> pRExprEqn + <|> (\(n,p) nl -> RExpr_Del p (n:nl)) + <$ pKey "-" <*> pNmSPos <*> pList pNm + pRExprEqn = RExprEqn_Attrs <$> pAttrEqns + <|> RExprEqn_Expr <$ pKey "=" <*> pExpr + pExpr = pExprApp + ((\es e1 -> let (op,e2) = foldr (\(op,e1) (f2,e2) -> (op,f2 e1 e2)) (const,undefined) es + in Expr_AppTop (op e1 e2) + ) + <$> pList1 ((,) <$> pOp <*> pExprApp) + ) + where pOp = (\s ss -> Expr_Op s (ss (Expr_Var s))) <$> pSym <*> pExprDot + pExprExplain = foldl1 Expr_SP <$> pList1 pW + where pW = pExprAtom (Nm <$> (pNmStr <|> pSymStr <|> pAnyKey pKey (keywordsOpsExplainEsc ++ keywordsText))) + <|> Expr_Expr <$ pKey "|" <*> pExpr <* pKey "|" + <|> Expr_Paren <$> pParens pExprExplain + pExprLF = pChainr (Expr_LF <$ pKey "|") pExpr + pExprLFSuffix nl = (\es e -> Expr_LF e (foldr1 Expr_LF es)) <$> pList1 (pKey nl *> pExpr) + pExprApp = mkApp alg <$> pList1 pExprBase <|> pSucceed Expr_Empty + pExprAtom pN = Expr_Var <$> pN + <|> Expr_Int <$> pInteger + <|> Expr_StrAsIs <$> pString + pExprBase' pN = pParens (pExprInParen <|> pExprSpecial) <**> pExprDot + <|> Expr_Uniq <$ pKey "unique" + <|> pExprAtom pN + pExprBase = pExprBase' pNmDir + pExprInParen = pExpr <**> ( flip Expr_Cnstr <$ pKey "|" <*> pECnstr + <|> pExprLFSuffix "-" + <|> pSucceed Expr_Paren + ) + pExprSpecial = (Expr_StrAsIs . concat) <$> pList1 (pAnyKey pKey (keywordsOpsParenEsc ++ keywordsTextEscapable)) + -- <|> Expr_Named <$> pNm <* pKey "=" <*> pExpr + <|> Expr_StrText <$ pKey "text" <*> pString + <|> Expr_Retain <$ pKey "retain" <*> pExpr + <|> Expr_ChildOrder <$ pKey "node" <*> pInt <* pKey "=" <*> pExpr + pExprDot = pSel (Expr_SelTop,Expr_Sel,Just) (pE,pMbE) + where pE = pExprBase' pNmBase + pMbE = Just <$> pE <|> pSucceed Nothing + pECnstr = ECnstr_Ty <$> pList1Sep pComma pNmC + <|> ECnstr_Var <$> pNmV + pTy = Ty_Con <$> pNmC + <|> Ty_App (Ty_Con nmList) <$> pBracks pTyApp + <|> pParens pTyApp + pTyApp = foldl1 Ty_App <$> pList1 pTy + pMbString = pMb pString + pFldIntros = pList pFldIntro + pFldIntro = FldIntro_Intro <$> pNm <* kDColon <*> pTy + pAttrIntros = pListSep pComma pAttrIntro + pAttrIntro = AttrIntro_Intro <$> pList pAttrProp <*> pNm <* kDColon <*> pNmC + pAttrEqns = pList (pKey "|" *> pAttrEqn) + pAttrEqn = AttrEqn_Eqn <$> pNmDir <* pKey "=" <*> pExpr + <|> AttrEqn_Del <$ pKey "-" <*> pNm + pAttrProp = foldr1 (<|>) [ v <$ pKey n | (n,v) <- Map.toList propsMp ] + pInt = read <$> pInteger + kDColon = pKey ":" <|> pKey "::" + kIsBar = pKey "=" <|> pKey "|" + in (pAGItf) + +%%] diff --git a/src/Ruler.chs b/src/Ruler.chs new file mode 100644 --- /dev/null +++ b/src/Ruler.chs @@ -0,0 +1,338 @@ +------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------- + +%%[1 hs module(Main) +%%] + +%%[1 hs import (System.IO, System.Environment, System.Exit, Control.Monad.State, qualified Data.Map as Map) +%%] + +%%[1 hs import (System.Console.GetOpt, UHC.Util.Pretty, UHC.Util.Utils( panicJust )) +%%] + +%%[1 hs import (UHC.Util.ParseUtils, UHC.Util.ParseErrPrettyPrint, UHC.Util.CompileRun) +%%] + +%%[1 hs import (Version, Err, Gam( emptyGam ), Common, Opts) +%%] + +%%[1 hs import (qualified AbsSyn.AbsSyn1 as AS1) +%%] + +%%[1 hs import (qualified Main1AG as M1) +%%] + +%%[1 hs import (qualified Main2AG as M2) +%%] + +%%[1 hs import (AS1.Imports, TrfAS2.GenARule, TrfAS2.GenLaTeX, KeywParser) +%%] + +%%[1 hs import (Parser, Expr.Expr, FmGam) +%%] + + +%%[1 hs + +------------------------------------------------------------------------- +-- Compile run state +------------------------------------------------------------------------- + +data RCompileUnitState + = RCUSUnknown | RCUSRuler | RCUSFail + deriving (Show,Eq) + +data RCompileUnit + = RCompileUnit + { rcuFilePath :: FPath + , rcuModNm :: Nm + , rcuMbOut :: Maybe AS1.AGItf + , rcuImpNmL :: [Nm] + , rcuState :: RCompileUnitState + } + +emptyRCU :: RCompileUnit +emptyRCU + = RCompileUnit + { rcuFilePath = emptyFPath + , rcuModNm = nmUnk + , rcuMbOut = Nothing + , rcuImpNmL = [] + , rcuState = RCUSUnknown + } + +rcuStoreMbOut x rcu = rcu {rcuMbOut = x} +rcuStoreImpNmL x rcu = rcu {rcuImpNmL = x} + +data RCompileRunStateInfo + = RCompileRunStateInfo + { crsiOpts :: Opts + , crsiImpPosMp :: ImpModMp + } + +instance FileLocatable RCompileUnit String where + fileLocation _ = "unknown" + noFileLocation = "unknown" + +instance CompileUnitState RCompileUnitState where + cusDefault = RCUSRuler + cusUnk = RCUSUnknown + cusIsUnk = (==RCUSUnknown) + cusIsImpKnown s = s /= RCUSUnknown + +instance CompileUnit RCompileUnit Nm String RCompileUnitState where + cuDefault = emptyRCU + cuFPath = rcuFilePath + cuLocation = fileLocation + cuKey = rcuModNm + cuState = rcuState + cuUpdFPath fp u = u {rcuFilePath = fp} + cuUpdLocation _ u = u + cuUpdState st u = u {rcuState = st} + cuUpdKey nm u = u {rcuModNm = nm} + cuImports = rcuImpNmL + +instance FPathError Err + +instance CompileRunError Err SPos where + crePPErrL = ppErrPPL + creMkNotFoundErrL p fp sp sufs = [Err_FileNotFound p fp sp] + creAreFatal = errLIsFatal + +instance CompileRunStateInfo RCompileRunStateInfo Nm SPos where + crsiImportPosOfCUKey n i = Map.findWithDefault emptySPos n (crsiImpPosMp i) + +instance CompileModName Nm where + mkCMNm = Nm + +type RCompileRun = CompileRun Nm RCompileUnit RCompileRunStateInfo Err +type RCompilePhase a = CompilePhase Nm RCompileUnit RCompileRunStateInfo Err a + +------------------------------------------------------------------------- +-- Pretty printing +------------------------------------------------------------------------- + +instance PP RCompileUnitState where + pp = pp . show + +instance Show RCompileUnit where + show _ = "RCU" + +instance PP RCompileUnit where + pp u = "RCU:" >#< pp (show $ rcuFilePath $ u) >#< ": state " >#< pp (rcuState u) >#< ": impL " >#< pp (show $ rcuImpNmL u) + +------------------------------------------------------------------------- +-- File suffix +------------------------------------------------------------------------- + +type FileSuffMp = [(FileSuffix,RCompileUnitState)] + +fileSuffMp :: FileSuffMp +fileSuffMp = [ ( Just "rul", RCUSRuler ), ( Just "", RCUSRuler ), ( Just "*", RCUSRuler ) ] + +------------------------------------------------------------------------- +-- Compile run actions +------------------------------------------------------------------------- + +cpParseCU :: Nm -> RCompilePhase () +cpParseCU modNm + = do { cr <- get + ; let cu = crCU modNm cr + fp = cuFPath cu + fNm = fpathToStr fp + ; (fn,fb,fh) + <- if fpathIsEmpty fp + then return ("","",stdin) + else do { let fn = fpathToStr fp + ; h <- lift $ openFile fn ReadMode + ; return (fn,fpathToStr (fpathRemoveSuff fp),h) + } + -- ; cpPP "crParseCU" + ; tokens <- lift $ mkHScan fn fh + ; let (pres,perrs) = parseToResMsgs pAGItf tokens + ; if null perrs + then do { let impMp = as1Imports pres + info = crStateInfo cr + ; cpUpdCU modNm (rcuStoreMbOut (Just pres) . rcuStoreImpNmL (Map.keys impMp)) + ; modify (\cr -> (cr {crStateInfo = info {crsiImpPosMp = impMp `Map.union` crsiImpPosMp info}})) + } + else cpSetLimitErrs 5 "" (map mkPPErr perrs) + } + +cpFindAndParseCU :: Maybe FPath -> Nm -> RCompilePhase () +cpFindAndParseCU mbFp modNm + = do { cr <- get + ; let opts = crsiOpts (crStateInfo cr) + cpFind mn mbFp + = do { _ <- cpFindFileForFPath fileSuffMp (optSearchPath opts) (Just mn) mbFp ; return ()} + ; cpSeq [cpFind modNm mbFp, cpParseCU modNm] + } + +cpFlattenAndCompileAllCU :: RCompilePhase () +cpFlattenAndCompileAllCU + = do { cr <- get + -- ; lift $ hPutStrLn stderr (show $ crCompileOrder cr) + ; let opts = crsiOpts (crStateInfo cr) + isAS2 = fmAS2Fm (optGenFM opts) /= optGenFM opts + parseRes = as1JoinAGItfs [ panicJust ("crFlattenAndCompileAllCU: " ++ show n) $ rcuMbOut $ crCU n $ cr | ns <- crCompileOrder cr, n <- ns ] + sem1Res + = M1.wrap_AGItf (M1.sem_AGItf parseRes) + (M1.Inh_AGItf + { M1.opts_Inh_AGItf = opts {optGenFM = fmAS2Fm (optGenFM opts)} + , M1.fmGam_Inh_AGItf = fmGamFromList' FmFmtCmd [ (Nm n,Expr_Var (Nm v)) | (n,v) <- optDefs opts ] + }) + hPutBld f h b = if f then hPutPPFile h b 2000 else return () + putBld f b = hPutBld f stdout b + cpPutBld f b = lift $ putBld f b + cpPutDbg = cpPutBld (optDebug opts) (M1.pp_Syn_AGItf sem1Res) + cpMk1 + = do { let t1 = M1.as2_Syn_AGItf sem1Res + ((t2,_,t2errL),doPrint) + = case optGenFM opts of + FmTeX -> bld as2LaTeX + FmAG -> bld as2ARule + FmHS -> ((t1,empty,[]),True) + _ | optGenExpl opts -> ((t1,empty,[]),True) + | otherwise -> ((t1,empty,[]),False) + where bld f = (f opts (M1.dtInvGam_Syn_AGItf sem1Res) (M1.scGam_Syn_AGItf sem1Res) (M1.fmGam_Syn_AGItf sem1Res) (M1.rwGam_Syn_AGItf sem1Res) t1,True) + ; cpSeq [cpSetErrs t2errL, cpPutBld doPrint (M2.ppAS2 opts (M1.fmGam_Syn_AGItf sem1Res) t2)] + } +{- + cpMk2 + = cpSeq [ cpPutBld True (M1.mkPP_Syn_AGItf sem1Res (optGenFM opts)) + , cpPutBld (optGenExpl opts) (M1.scExplPP_Syn_AGItf sem1Res) + ] + cpMk3 f + = do { let t1 = M1.as2_Syn_AGItf sem1Res + (t2,t2ppDbg,t2errL) + = case f of + FmTeX -> as2LaTeX opts (M1.scGam_Syn_AGItf sem1Res) (M1.fmGam_Syn_AGItf sem1Res) (M1.rwGam_Syn_AGItf sem1Res) t1 + FmAG -> as2ARule opts (M1.scGam_Syn_AGItf sem1Res) (M1.fmGam_Syn_AGItf sem1Res) (M1.rwGam_Syn_AGItf sem1Res) t1 + ; cpSeq [ cpSetErrs t2errL + , cpPutBld True t2ppDbg + , cpPutBld True (M2.ppAS2 opts t2) + , cpPutBld True (M1.mkPP_Syn_AGItf sem1Res f) + ] + } +-} + ; cpSeq [ cpPutDbg + , cpSetErrs (M1.errL_Syn_AGItf sem1Res) + , cpMk1 +{- + , if optGenV2 opts && not isAS2 + then cpMk1 + else if not isAS2 + then cpMk2 + else case optGenFM opts of + FmAS2 f -> cpMk3 f + _ -> liftCR id +-} + ] + } + +compileTopLevel :: FPath -> Opts -> IO () +compileTopLevel fp opts + = do { let topModNm = Nm (fpathBase fp) + opts' = opts { optSearchPath = mkInitSearchPath fp ++ optSearchPath opts } + cr = mkEmptyCompileRun topModNm (RCompileRunStateInfo opts' Map.empty) + ; _ <- runStateT (cpSeq [ cpFindAndParseCU (Just fp) topModNm + -- , crPP "crCompileTopLevel 1" + , cpImportGather (cpFindAndParseCU Nothing) topModNm + -- , crPP "crCompileTopLevel 2" + , cpFlattenAndCompileAllCU + ]) + cr + ; return () + } + +------------------------------------------------------------------------- +-- main +------------------------------------------------------------------------- + +main :: IO () +main + = do { args <- getArgs + ; let oo@(o,n,errs) = getOpt Permute cmdLineOpts args + opts = foldr ($) defaultOpts o + ; if optHelp opts + then putStrLn (usageInfo ("version: " ++ versionInfo ++ "\n\nUsage ruler [options] [file]\n\noptions:") cmdLineOpts) + else if optVersion opts || optSvnVersion opts + then do { let s = (if optVersion opts then versionDist else "") + ++ (if optVersion opts && optSvnVersion opts then ", " else "") + ++ (if optSvnVersion opts then versionSvn else "") + ; putStr s + } + else if null errs + -- then doCompile (if null n then emptyFPath else mkFPath (head n)) opts + then compileTopLevel (if null n then emptyFPath else mkFPath (head n)) opts + else do hPutStr stderr (head errs) + exitFailure + } + +{- +doCompile :: FPath -> Opts -> IO () +doCompile fp opts + = do { (fn,fb,fh) + <- if fpathIsEmpty fp + then return ("","",stdin) + else do { let fn = fpathToStr fp + ; h <- openFile fn ReadMode + ; return (fn,fpathToStr (fpathRemoveSuff fp),h) + } + ; tokens <- mkOffScan fn fh + ; let (pres,perrs) = parseOffsideToResMsgs pAGItf tokens + (showErrs,omitErrs) = splitAt 5 perrs + ; putErr' (if null omitErrs then return () else hPutStrLn stderr "... and more parsing errors") (map mkPPErr showErrs) + ; let res = M1.wrap_AGItf (M1.sem_AGItf pres) + (M1.Inh_AGItf + { M1.opts_Inh_AGItf = opts {optGenFM = fmAS2Fm (optGenFM opts)} + }) + putDbg = putBld (optDebug opts) (M1.pp_Syn_AGItf res) + errL = M1.errL_Syn_AGItf res + ; putDbg + ; putErr errL + ; let isAS2 = fmAS2Fm (optGenFM opts) /= optGenFM opts + ; if optGenV2 opts && not isAS2 + then do { let t1 = M1.as2_Syn_AGItf res + ((t2,_,t2errL),doPrint) + = case optGenFM opts of + FmTeX -> bld as2LaTeX + FmAG -> bld as2ARule + _ -> ((t1,empty,[]),False) + where bld f = (f opts (M1.scGam_Syn_AGItf res) (M1.fmGam_Syn_AGItf res) (M1.rwGam_Syn_AGItf res) t1,True) + ; putErr t2errL + ; putBld doPrint (M2.ppAS2 opts t2) + } + else if not isAS2 + then do { putBld True (M1.mkPP_Syn_AGItf res (optGenFM opts)) + ; putBld (optGenExpl opts) (M1.scExplPP_Syn_AGItf res) + } + else case optGenFM opts of + FmAS2 f + -> do { putErr t2errL + ; putBld True t2ppDbg + ; putBld True (M2.ppAS2 opts t2) + ; putBld True (M1.mkPP_Syn_AGItf res f) + } + where t1 = M1.as2_Syn_AGItf res + (t2,t2ppDbg,t2errL) + = case f of + FmTeX -> as2LaTeX opts (M1.scGam_Syn_AGItf res) (M1.fmGam_Syn_AGItf res) (M1.rwGam_Syn_AGItf res) t1 + FmAG -> as2ARule opts (M1.scGam_Syn_AGItf res) (M1.fmGam_Syn_AGItf res) (M1.rwGam_Syn_AGItf res) t1 + _ -> return () + } + where hPutBld f h b = if f then hPutPPFile h b 2000 else return () + putBld f b = hPutBld f stdout b + -- putErr' :: IO () -> [Err] -> IO () + putErr' m e = if null e + then return () + else do { hPutBld True stderr (ppErrPPL e) + ; m + ; if errLIsFatal e then exitFailure else return () + } + -- putErr :: [Err] -> IO () + putErr = putErr' (return ()) +-} + +%%] diff --git a/src/RwExprGam.chs b/src/RwExprGam.chs new file mode 100644 --- /dev/null +++ b/src/RwExprGam.chs @@ -0,0 +1,20 @@ +------------------------------------------------------------------------- +-- RwExpr Gamma +------------------------------------------------------------------------- + +%%[1 hs module (RwExprGam) +%%] + +%%[1 hs export (module FmGam, RwExprGam) +%%] + +%%[1 hs import (Common, FmGam, Expr.Expr) +%%] + +------------------------------------------------------------------------- +-- Gam +------------------------------------------------------------------------- + +%%[1 hs +type RwExprGam = RwGam (Expr,Expr) +%%] diff --git a/src/Scanner.chs b/src/Scanner.chs new file mode 100644 --- /dev/null +++ b/src/Scanner.chs @@ -0,0 +1,92 @@ +%%[1 hs module (Scanner) +%%] + +%%[1 hs export (module ScannerMachine) +%%] + +%%[1 hs export (module UU.Scanner.Token) +%%] + +%%[1 hs export (module UU.Scanner.TokenParser) +%%] + +%%[1 hs export (module UU.Scanner.Position) +%%] + +%%[1 hs export (SPos, emptySPos) +%%] + +%%[1 hs export (scanFile, scanHandle) +%%] + +%%[1 hs export (offsideScanHandle) +%%] + +%%[1 hs import (System.IO) +%%] + +%%[1 hs import (ScannerMachine) +%%] + +%%[1 hs import (UU.Scanner.Token) +%%] + +%%[1 hs import (UU.Scanner.TokenParser) +%%] + +%%[1 hs import (UU.Scanner.Position) +%%] + +%%[1 hs import (UHC.Util.ScanUtils) +%%] + +%%[1 hs import (UU.Parsing.Offside) +%%] + +-- instances +%%[1 hs import (UU.Scanner.TokenShow()) +%%] + +%%[1 hs import (UU.Scanner.GenTokenOrd()) +%%] + +%%[1 hs import (UU.Scanner.GenTokenSymbol()) +%%] + + +%%[1 hs + +------------------------------------------------------------------------- +-- Symbol position +------------------------------------------------------------------------- + +type SPos = (String,Pos) + +emptySPos = ("",noPos) + +------------------------------------------------------------------------- +-- Wrappers around scan +------------------------------------------------------------------------- + +scanHandle :: ScanOpts -> FilePath -> Handle -> IO [Token] +scanHandle opts fn fh + = do { txt <- hGetContents fh + ; return (scan opts (initPos fn) txt) + } + +scanFile :: ScanOpts -> FilePath -> IO [Token] +scanFile opts fn = + do txt <- readFile fn + return (scan opts (initPos fn) txt) + +offsideScanHandle :: ScanOpts -> FilePath -> Handle -> IO (OffsideInput [Token] Token (Maybe Token)) +offsideScanHandle opts fn fh + = do { tokens <- scanHandle opts fn fh + ; return (scanOffside moduleT oBrace cBrace triggers tokens) + } + where moduleT = reserved (scoOffsideModule opts) noPos + oBrace = reserved (scoOffsideOpen opts) noPos + cBrace = reserved (scoOffsideClose opts) noPos + triggers = [ reserved x noPos | x <- scoOffsideTrigs opts ] + +%%] diff --git a/src/ScannerMachine.chs b/src/ScannerMachine.chs new file mode 100644 --- /dev/null +++ b/src/ScannerMachine.chs @@ -0,0 +1,262 @@ +%%[1 hs module (ScannerMachine) +%%] + +%%[1 hs export(scan) +%%] + +%%[1 hs import (Data.Char(isLower, isUpper, isSpace, isAlphaNum, isDigit, chr, ord)) +%%] + +%%[1 hs import (Data.List(sort), Data.Maybe(isJust)) +%%] + +%%[1 hs import (qualified Data.Set as Set) +%%] + +%%[1 hs import (UU.Scanner.Token(Token, EnumValToken(..), valueToken, reserved, errToken)) +%%] + +%%[1 hs import (UU.Scanner.Position(Pos, initPos, advc, adv)) +%%] + +%%[1 hs import (UHC.Util.ScanUtils) +%%] + +%%[1 hs + +{- A parametrisable scanner + - + - Author: Doaitse Swierstra: doaitse@cs.uu.nl + and: Pablo Azero : pablo@cs.uu.nl + - Version 1.0 , May 25, 1998, SDS + first appearance on the software web site. + - Version 1.01, June 7, 1998, SDS + changed String recognition to recognise escaped characters + - Version 1.02, Aug 30, 1998, SDS + includes with unsafePerformIO + - Version 2.1, Jul 7, 1999, slightly different definition of valueToken + ordering between tokens introduced + - Version 2.2, Jul 8, 1999, AG_Scanner and UU_Scanner merged + - Version 2.3, Jul 15, 1999, modifications: recognize decimal, octal and + - hexadecimal numbers; handles ' as part of a + - lower case identifier + - fixes: bug in msort (loops when passing an + - empty list) + - Version 2.4, Jul 23, 1999, additions: recognize characters and infix + - operators + - + - Lang. compat: Hugs 98 (because it is required by UU_Parsing) + - Version 2.5, Aug 15, 1999, changed names, pSym -> pSpec + , all parsers start with p.... + - Version 2.6, Sept 15, 1999, changed error message for unterminated string + - Version 2.7, Sept 23, 1999, changed definition of pOper_Any + - Version 2.8 Aug 14, 2000, adapted to changes in search trees + - ?? Oct 25, 2000, adapted to use column numbers + - ?? Feb 2, 2001, incorporated changes of AD + - ?? Feb 28, 2001, tabs are handled correctly for column numbers + - ?? Mar 1, 2001, now generates space tokens that have to be filtered again + - ?? Apr 4, 2001, tabs are now handled relative to current column number + - ?? Feb 24, 2006, cloned for use in Ruler + -} + +scan :: ScanOpts -> Pos -> String -> [Token] +scan opts pos input + = doScan pos input + + where + -- locatein :: Ord a => [a] -> a -> Bool + -- locatein es = isJust . btLocateIn compare (tab2tree (sort es)) + + iskw = (`Set.member` scoKeywordsTxt opts) -- locatein (scoKeywordsTxt opts) + isop = (`Set.member` scoKeywordsOps opts) -- locatein (scoKeywordsOps opts) + isSymbol = (`Set.member` scoSpecChars opts) -- locatein (scoSpecChars opts) + isOpsym = (`Set.member` scoOpChars opts) -- locatein (scoOpChars opts) + + + isIdStart c = isLower c || c == '_' + + isIdChar c = isAlphaNum c + || c == '\'' + || c == '_' + + scanFor f p s = let (name,rest) = span f s + in (name,advc (length name) p,rest) + scanIdent = scanFor isIdChar + scanDash = scanFor (== '-') + + doScan p [] = [] + doScan p (c:s) | isSpace c = let (sp,next) = span isSpace s + in doScan (foldl adv p (c:sp)) next + + doScan p ('-':'-':'-':'-':s) = doScan p (dropWhile (/= '\n') s) + doScan p ('-':'-':'-':s) + = let (_,p',s') = scanDash (advc 3 p) s + dash = "---" + tok | isop dash = reserved dash p + | otherwise = valueToken TkOp dash p + in tok : doScan p' s' + doScan p ('-':'-':s) = doScan p (dropWhile (/= '\n') s) + doScan p ('{':'-':s) = lexNest doScan (advc 2 p) s + doScan p ('"':ss) + = let (s,swidth,rest) = scanString ss + in if null rest || head rest /= '"' + then errToken "Unterminated string literal" p : doScan (advc swidth p) rest + else valueToken TkString s p : doScan (advc (swidth+2) p) (tail rest) + + doScan p ('\'':ss) + = let (mc,cwidth,rest) = scanChar ss + in case mc of + Nothing -> errToken "Error in character literal" p : doScan (advc cwidth p) rest + Just c -> if null rest || head rest /= '\'' + then errToken "Unterminated character literal" p : doScan (advc (cwidth+1) p) rest + else valueToken TkChar [c] p : doScan (advc (cwidth+2) p) (tail rest) + + {- + In Haskell infix identifiers consist of three separate tokens(two backquotes + identifier) + doScan p ('`':ss) + = case ss of + [] -> [errToken "Unterminated infix identifier" p] + (c:s) -> let res | isIdStart c || isUpper c = + let (name,p1,rest) = scanIdent (advc 2 p) s + ident = c:name + tokens | null rest || + head rest /= '`' = errToken "Unterminated infix identifier" p + : doScan p1 rest + | iskw ident = errToken ("Keyword used as infix identifier: " ++ ident) p + : doScan (advc 1 p1) (tail rest) + | otherwise = valueToken TkOp ident p + : doScan (advc 1 p1) (tail rest) + in tokens + | otherwise = errToken ("Unexpected character in infix identifier: " ++ show c) p + : doScan (adv p c) s + in res + -} + doScan p cs@(c:s) + | isSymbol c = reserved [c] p + : doScan(advc 1 p) s + | isIdStart c || isUpper c + = let (name', p', s') = scanIdent (advc 1 p) s + name = c:name' + tok = if iskw name + then reserved name p + else if null name' && isSymbol c + then reserved [c] p + else valueToken (if isIdStart c then TkVarid else TkConid) name p + in tok : doScan p' s' + | isOpsym c = let (name, s') = span isOpsym cs + tok | isop name = reserved name p + | c==':' = valueToken TkConOp name p + | otherwise = valueToken TkOp name p + in tok : doScan (foldl adv p name) s' + | isDigit c = let (tktype,number,width,s') = getNumber cs + in valueToken tktype number p : doScan (advc width p) s' + | otherwise = errToken ("Unexpected character " ++ show c) p + : doScan (adv p c) s + +{- + +-- ks: no clean implementation of columns +readname s lc = (name,orest,nlc) + where (line,irest) = span (/='\n') s + orest = if null irest then "" else irest + nlc = if null irest then lc else (lc `advl` 1) + name = takename . dropWhile (\x -> not $ x `elem` "{[") $ line + takename ln | null ln = "" + | otherwise = if not (null tln) && (isAlpha . head $ tln) + then if not (null rln) && (head rln `elem` "}]") + then cname + else err lc 1 + else err lc 1 + where (cname, rln) = span validChar tln + tln = tail ln + validChar c = isAlpha c || c `elem` ".-_" || isDigit c + +-- ks: changed definition from (lc+1) to (lc) +err lc 1 = error ("in scanner bad name definition" ++ maybeshow (lc)) +err lc fn 2 + = error ("in scanner not a valid name in file inclusion" ++ maybeshow (lc)) +-} +lexNest :: (Pos -> String -> [Token]) + -> Pos + -> String + -> [Token] +lexNest cont pos inp = lexNest' cont pos inp + where lexNest' c p ('-':'}':s) = c (advc 2 p) s + lexNest' c p ('{':'-':s) = lexNest' (lexNest' c) (advc 2 p) s + lexNest' c p (x:s) = lexNest' c (adv p x) s + lexNest' _ _ [] = [ errToken "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 + +scanChar :: [Char] -> (Maybe Char,Int,[Char]) +scanChar ('"' :xs) = (Just '"',1,xs) +scanChar xs = getchar xs + +getchar :: [Char] -> (Maybe Char,Int,[Char]) +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 :: [Char] -> (Maybe Char,Int,[Char]) +getEscChar [] = (Nothing,0,[]) +getEscChar s@(x:xs) | isDigit x = let (tp,n,len,rest) = getNumber s + val = case tp of + TkInteger8 -> readn 8 n + TkInteger16 -> readn 16 n + TkInteger10 -> readn 10 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 -> [Char] -> Int +readn base n = foldl (\r x -> value x + base * r) 0 n + +getNumber :: [Char] -> (EnumValToken,[Char],Int,[Char]) +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 = (TkInteger10, "0",1,s) + num10 = let (n,r) = span isDigit cs + in (TkInteger10,n,length n,r) + num16 = readNum isHexaDigit ts TkInteger16 + num8 = readNum isOctalDigit ts TkInteger8 + readNum p ts tk + = let nrs@(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 + +%%] diff --git a/src/SelParser.chs b/src/SelParser.chs new file mode 100644 --- /dev/null +++ b/src/SelParser.chs @@ -0,0 +1,28 @@ +------------------------------------------------------------------------- +-- Sel parser +------------------------------------------------------------------------- + +%%[1 hs module (SelParser) +%%] + +%%[1 hs export (pSel1, pSel) +%%] + +%%[1 hs import (UU.Parsing, Scanner, UHC.Util.ParseUtils, Config( cfgStrSel )) +%%] + +------------------------------------------------------------------------- +-- Parser +------------------------------------------------------------------------- + +%%[1 hs + +pSel1 :: (IsParser p Token) => (a1 -> t, a1 -> a -> a1, a2 -> a) -> (p a2, p a) -> p (a1 -> t) +pSel1 (top,sel,jst) (pE,pMbE) + = (\ss s -> \e -> top (sel (ss e) (jst s))) <$> pDots <*> pE + where pSel' = flip sel <$> pMbE + pDots = pChainr_ng ((\s -> \_ r -> \e -> r (s e)) <$> pSel') (id <$ pKey cfgStrSel) + +pSel alg ps = pSel1 alg ps <|> pSucceed id + +%%] diff --git a/src/TrfAS2/CommonAG.cag b/src/TrfAS2/CommonAG.cag new file mode 100644 --- /dev/null +++ b/src/TrfAS2/CommonAG.cag @@ -0,0 +1,62 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- Common for transformations on AS2 +------------------------------------------------------------------------- + +------------------------------------------------------------------------- +-- Replica +------------------------------------------------------------------------- + +ATTR AGItf [ | | self: {Decls} ] +ATTR AllAS2 [ | | self: SELF ] + +------------------------------------------------------------------------- +-- Context: scGam, fmGam, rwGam +------------------------------------------------------------------------- + +ATTR AllAS2 AGItf [ scGam: {ScGam Expr} fmGam: {FmGam Expr} rwGam: RwExprGam | | ] + +------------------------------------------------------------------------- +-- Context: options, etc +------------------------------------------------------------------------- + +ATTR AllAS2 [ fm: FmKind | | ] + +SEM AGItf + | AGItf loc . fm = fmAS2Fm (optGenFM @lhs.opts) + . opts = @lhs.opts {optGenFM = @fm} + +------------------------------------------------------------------------- +-- Context: ruleset/view/rule name, agStr +------------------------------------------------------------------------- + +ATTR AllVw AllRl [ rsScNm: Nm | | ] + +SEM RsVwDecl + | Rs loc . rsScNm = @scNm + +ATTR AllRl AllJd [ vwNm: Nm | | ] + +SEM VwDecl + | Vw LTX loc . vwNm = @nm + +ATTR AllJd [ rlNm: Nm | | ] + +SEM RlDecl + | Rl loc . rlNm = @nm + | LTX loc . rlNm = @rlNm + +------------------------------------------------------------------------- +-- Debug pretty printing of ruler AST2 +------------------------------------------------------------------------- + +ATTR AllAS2 AGItf [ | | ppDbg USE {>-<} {empty} : PP_Doc ] + +------------------------------------------------------------------------- +-- Error +------------------------------------------------------------------------- + +ATTR AllDecl AGItf [ | | errL USE {++} {[]}: {[Err]} ] + +%%] diff --git a/src/TrfAS2/GenARule.cag b/src/TrfAS2/GenARule.cag new file mode 100644 --- /dev/null +++ b/src/TrfAS2/GenARule.cag @@ -0,0 +1,433 @@ +------------------------------------------------------------------------- +-- Generate ARule's from attr bindings +------------------------------------------------------------------------- + +%%[1 hs module (TrfAS2.GenARule) +%%] + +%%[1 hs export (as2ARule) +%%] + +%%[1 hs import (Data.Maybe, Data.Char, Data.List, qualified Data.Set as Set, qualified Data.Map as Map, UHC.Util.Utils) +%%] + +%%[1 hs import (Opts, Err, Common, KeywParser( propsSynInhMp ), Expr.Utils, ARule.Utils, FmGam, RwExprGam) +%%] + +%%[1 hs import (ECnstrGam, AbsSyn.AbsSyn2, Admin, Utils( sc2DATA )) +%%] + +%%[1 hs import (UHC.Util.Pretty) +%%] + +------------------------------------------------------------------------- +-- Inclusion of split off parts +------------------------------------------------------------------------- + +%%[1 ag import ({AbsSyn/AbsSyn2AG}, {AbsSyn/CommonAG}, {AS2/Opts}, {TrfAS2/CommonAG}) +%%] + +%%[1 ag import ({Expr/AbsSynAG}, {Expr/SelfAG}) +%%] + +%%[1 ag import ({ARule/AbsSynAG}, {ARule/SelfAG}) +%%] + +------------------------------------------------------------------------- +-- Interfacing to AST +------------------------------------------------------------------------- + +%%[1 ag +WRAPPER AGItf +%%] + +%%[1 hs +as2ARule :: Opts -> DtInvGam -> ScGam Expr -> FmGam Expr -> RwExprGam -> Decls -> (Decls,PP_Doc,[Err]) +as2ARule o dig scg fmg rwg r + = (self_Syn_AGItf r2,ppDbg_Syn_AGItf r2,errL_Syn_AGItf r2) + where r1 = sem_AGItf (AGItf_AGItf r) + r2 = wrap_AGItf r1 + (Inh_AGItf {opts_Inh_AGItf = o, fmGam_Inh_AGItf = fmg, rwGam_Inh_AGItf = rwg, scGam_Inh_AGItf = scg, dtInvGam_Inh_AGItf = dig}) +%%] + +------------------------------------------------------------------------- +-- Context: dtInvGam +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllAS2 AGItf [ dtInvGam: DtInvGam | | ] +%%] + +------------------------------------------------------------------------- +-- Context: options, position, etc +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllJd AllAt [ pos: SPos | | ] + +SEM RlDecl + | Rl LTX loc . pos = @pos +%%] + +------------------------------------------------------------------------- +-- Context: substitution +------------------------------------------------------------------------- + +%%[1 ag +SEM JdAt + | At loc . sbse = exprSubst (@lhs.opts {optSubstFullNm=False}) @lhs.fmGam + . sbsn = nmSubst (@lhs.opts {optSubstFullNm=False}) @lhs.fmGam + +SEM Jd + | Ats loc . sbse = exprSubst (@lhs.opts {optSubstFullNm=False}) @lhs.fmGam + . sbsn = nmSubst (@lhs.opts {optSubstFullNm=False}) @lhs.fmGam + +SEM RlDecl + | Rl loc . sbse = exprSubst (@lhs.opts {optSubstFullNm=False}) @lhs.fmGam + . sbsn = nmSubst (@lhs.opts {optSubstFullNm=False}) @lhs.fmGam +%%] + +------------------------------------------------------------------------- +-- Context: scInfo, ... + dtInfo, ... +------------------------------------------------------------------------- + +%%[1 ag +SEM RlDecl + | Rl loc . rsScInfo = maybe (panic "RlDecl_Rl: rsScInfo") id $ gamLookup @lhs.rsScNm @lhs.scGam + . (_,_,daInvInfo) + = maybe (undefined,undefined,emptyDtAltInvInfo) id + $ dtVwRlInvGamLookup @lhs.rsScNm @lhs.vwNm @rlNm @lhs.dtInvGam + +SEM Jd + | Ats loc . (scInfo,vwScInfo) + = maybe (panic "Jd_Ats: scInfo") id + $ scVwGamLookup @scNm @lhs.vwNm @lhs.scGam +%%] + +------------------------------------------------------------------------- +-- Context: is a judgement (and not a relation)? +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllAt [ isJd: Bool | | ] + +SEM Jd + | Ats loc . isJd = scKind @scInfo == ScJudge +%%] + +------------------------------------------------------------------------- +-- Context: is in premise? +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllJd AllAt [ isPre: Bool | | ] + +SEM RlDecl + | Rl LTX preJds . isPre = True + postJds . isPre = False +%%] + +------------------------------------------------------------------------- +-- Context: name info from higher up +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllJd [ agStr: Nm | | ] + +SEM RlDecl + | Rl loc . agStr = @agStr + | * - Rl loc . agStr = nmNone +%%] + +------------------------------------------------------------------------- +-- Context: scAtGam +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllAt [ scAtGam: AtGam | | ] + +SEM Jd + | Ats ats . scAtGam = vwscFullAtGam @vwScInfo + +SEM JdAt + | At loc . atInfo = maybe emptyAtInfo id $ gamLookup @nm @lhs.scAtGam + . propRetain = [AtRetain] `atFilterProps` @atInfo +%%] + +------------------------------------------------------------------------- +-- Local properties for attr +------------------------------------------------------------------------- + +%%[1 ag +SEM JdAt + | At loc . dir = atDefUse @lhs.isPre @atInfo + . isBi = Map.elems propsSynInhMp `atHasProps` @atInfo + . isExtern = AtExtern `atHasProp` @atInfo + +SEM JdAt + | At loc . atTy = atTy @atInfo + . atCnstr = ECnstr_Ty [@atTy] +%%] + +------------------------------------------------------------------------- +-- Context: node name +------------------------------------------------------------------------- + +%%[1 ag +ATTR JdAt [ | | mbNmNd: {Maybe Nm} ] +ATTR JdAts [ | | gathNmNd: Nm ] + +ATTR AllAt [ | | gathExNd: Expr ] + +SEM JdAt + | At lhs . mbNmNd = if @dir == ADNode then Just @nm else Nothing + . gathExNd = @expr.self + +SEM JdAts + | Nil lhs . gathNmNd = nmUnk + . gathExNd = exprUnk + | Cons lhs . (gathNmNd,gathExNd) + = maybe (@tl.gathNmNd,@tl.gathExNd) (\n -> (n,@hd.gathExNd)) @hd.mbNmNd + +ATTR AllAt [ nmNd: Nm | | ] + +SEM Jd + | Ats loc . nmNd = if @lhs.isPre then exprAsNm $ @sbse $ @ats.gathExNd else nmLhs +%%] + +------------------------------------------------------------------------- +-- Scheme of children node map/gam +------------------------------------------------------------------------- + +ATTR AllJd [ | | ndToScGam USE {`gamUnion`} {Map.empty}: {Gam Nm Nm} ] + +SEM Jd + | Ats lhs . ndToScGam = gamSingleton @nmNd @scNm + +------------------------------------------------------------------------- +-- Node order gam +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllJd [ | | coGam USE {`gamUnion`} {emptyGam}: ChOrdGam ] + +SEM Jd + | Ats loc . exNdNmS = exprNmS @ats.gathExNd + . exNdFmGam = fmGamFromList' @lhs.fm [ (n,mkAFld . @sbsn $ n) | n <- Set.toList @exNdNmS ] + lhs . coGam = let sbse = exprSubst (@lhs.opts {optSubstFullNm=False}) @exNdFmGam + cg1 = exprCoGam . sbse $ @ats.gathExNd + in cg1 + +SEM RlDecl + | Rl loc . coNmL = let cg1 = @postJds.coGam + cg2 = gamMapKeys @sbsn $ daiChOrdGam @daInvInfo + in coGamNmL (if gamIsEmpty cg1 then cg2 else cg1) +%%] + +------------------------------------------------------------------------- +-- Attr bindings as FmGam +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllAt [ | | atFmGam USE {`fmGamUnion`} {emptyGam}: {FmGam (Expr,ECnstr)} ] + +SEM JdAt + | At lhs . atFmGam = if False -- exprAsNm @expr.self == nmWild + then emptyGam + else fmSingleton @nm @lhs.fm (@expr.self,@atCnstr) +%%] + +------------------------------------------------------------------------- +-- Building blocks for transforming +------------------------------------------------------------------------- + +%%[1 ag +SEM JdAt + | At loc . nmAdapt = if @isBi then nmInit else id + . nmSbs = Nm . nmShowAG . @sbsn . @nmAdapt $ @nm + . defLhs = if @lhs.isPre then mkANd @lhs.nmNd @nmSbs else mkALhs' @propRetain @nmSbs + . defRhs = @expr.self + . useLhs = @expr.self + . useRhs = if @lhs.isPre then mkANd @lhs.nmNd @nmSbs else mkALhs @nmSbs +%%] + +------------------------------------------------------------------------- +-- Introduced names, mapped to AG equivalent +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllJd AllAt [ | | introFmGam USE {`fmGamUnion`} {emptyGam}: {FmGam Expr} ] + +SEM JdAt + | At loc . introFmGam = case @dir of + ADUse -> fmGamFromList' @lhs.fm [ (n,mkALoc' n') | (n,n') <- nmRefAscL ] + where nmRefAscL = [ (n,Nm . nmShowAG . @sbsn {- . nmAdapt -} $ n) | n <- Set.toList (exprNmS @useLhs), n /= nmWild ] + _ -> emptyGam + +SEM Jd + | Ats lhs . introFmGam = case scKind @scInfo of + ScJudge | not @lhs.isPre -> @exNdFmGam `fmGamUnion` @ats.introFmGam + _ -> @ats.introFmGam + +SEM RlDecl + | Rl loc . introFmGam = @preJds.introFmGam `fmGamUnion` @postJds.introFmGam +%%] + +------------------------------------------------------------------------- +-- Full fmGam +------------------------------------------------------------------------- + +%%[1 ag +SEM RlDecl + | Rl loc . fullFmGam = @introFmGam `fmGamUnion` @lhs.fmGam +%%] + +------------------------------------------------------------------------- +-- Constraint gam +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllJd AllAt [ | | introECGam USE {`gamUnion`} {emptyGam}: ECnstrGam ] + +SEM JdAt + | At lhs . introECGam = @introECGam + +SEM Jd + | Ats lhs . introECGam = @introECGam + +SEM RlDecl + | Rl loc . introECGam = gamMapKeys + (exprSubst (@lhs.opts {optSubstFullNm=False}) @fullFmGam) + (@preJds.introECGam `gamUnion` @postJds.introECGam) +%%] + +------------------------------------------------------------------------- +-- 'Attr defined' gam +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllJd AllAt [ | | introADGam USE {`gamUnion`} {emptyGam}: AtDefdGam ] + +SEM JdAt + | At lhs . introADGam = case @dir of + ADDef -> gamFromAssocs [(@nmSbs,@isBi)] + _ -> emptyGam + +SEM RlDecl + | Rl loc . adGam = @preJds.introADGam `gamUnion` @postJds.introADGam +%%] + +------------------------------------------------------------------------- +-- 'Attr defined' gam, new version +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllJd AllAt [ | | introAD2Gam USE {`adGamUnion`} {emptyGam}: {AtDefdGam'} ] + +SEM JdAt + | At lhs . introAD2Gam = case @dir of + ADUse | @lhs.isJd + -> gamFromAssocs [(@nmSbs,Set.singleton @lhs.nmNd)] + _ -> emptyGam + +SEM RlDecl + | Rl loc . ad2Gam = @preJds.introAD2Gam `adGamUnion` @postJds.introAD2Gam +%%] + +------------------------------------------------------------------------- +-- Replica +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllAt AllJd [ | | exprEqnL USE {++} {[]}: {[Expr]} ] + +SEM JdAt + | At loc . (exprEqnL,introECGam) + = let mk l r = ([eqn2],ecGam `gamUnion` ecGamFromList [ (l,@atCnstr), (r,@atCnstr) ]) + where eqn1 = mkExprEqn l r + (eqn2,ecGam) = exprElimCnstr eqn1 + in case @dir of + ADUse | not (fmNull @introFmGam) + -> mk @useLhs @useRhs + ADDef | not @isExtern + -> mk @defLhs @defRhs + _ -> ([],emptyGam) + +SEM Jd + | Ats loc . (exprEqnL,introECGam,eqnErrs) + = case scKind @scInfo of + ScJudge + -> (@ats.exprEqnL,@ats.introECGam,[]) + ScRelation + -> (exprLines jd2,introECGam2,concat jd1ErrLL) + where jd1 = fkGamLookup exprUnk jdshExpr [@lhs.fm] . vwscJdShpGam $ @vwScInfo + (jd1EqlL,jd1ErrLL) + = unzip + [ maybe (Map.empty,[Err_NotAEqnForm @lhs.pos (pp l)]) (\e -> (e,[])) (exprCheckAEqnForm l) + | l <- exprLines jd1 + ] + jd2 = exprSubst (@lhs.opts {optSubstOnce=True}) (fmGamMap (const fst) @ats.atFmGam) jd1 + mkG eqm gn + = if null n1 then [] else n1 ++ mkG (foldr (\(e,_) m -> Map.delete e m) eqm n1) n1 + where n1 = [ (exprEnsureAppTop e',c) | (e,c) <- gn, e' <- maybeToList (Map.lookup e eqm) ] + (introECL,introECGL) + = unzip [ ((e,c),eg) | (_,(e,c)) <- fmGamToList' @lhs.fm @ats.atFmGam, let (e',eg) = exprElimCnstr e ] + introECGam2 + = (ecGamFromList $ introECL ++ mkG (Map.unions jd1EqlL) introECL) + `gamUnion` gamUnions introECGL + +SEM RlDecl + | Rl (lhs.self,loc.selfNonOptim1,loc.selfNonOptim2) + = let (eqnLL,eqnGamL) + = unzip + [ (es,g) + | e <- @preJds.exprEqnL ++ @postJds.exprEqnL + , let (_,es,g) = exprRewrite' (@lhs.opts {optSubstFullNm=False}) @fullFmGam @lhs.rwGam @introECGam e + ] + aRule1 + = ARule_Rule + [sc2DATA @rsScInfo @lhs.dtInvGam] + @agStr + ["rule " ++ show @rlNm,"view " ++ show @lhs.vwNm] + (concat eqnLL) + aRule2 + = arlUniq @lhs.fmGam @coNmL + $ arlSubst (fmGamUnions eqnGamL) + $ aRule1 + aRule3 + = arlElimAlphaRename + $ aRule2 + aRule4 + = arlElimWild + $ (if optAGCopyElim @lhs.opts then arlElimCopyRule @coNmL @adGam @ad2Gam else id) + $ aRule3 + in (RlDecl_AG @nm @pos aRule4,aRule2,aRule3) +%%] + +------------------------------------------------------------------------- +-- Debug pretty printing of ruler AST2 +------------------------------------------------------------------------- + +%%[1 ag +SEM RlDecl + | Rl lhs . ppDbg = "-- debug info" + >-< @nm >#< ppBracketsCommas [pp @pos,pp @agStr] + >-< "introFmGam" >#< ppGam @introFmGam + >-< "introECGam" >#< ppECGam @introECGam + >-< "lhs.rwGam" >#< ppGam @lhs.rwGam + >-< "adGam" >#< ppGam @adGam + >-< "ad2Gam" >#< ppADGam @ad2Gam + >-< "lhs.opts" >#< text (show @lhs.opts) + >-< "coNmL" >#< ppListSep "[" "]" "," @coNmL + >-< "non optim1" >#< pp @selfNonOptim1 + >-< "non optim2" >#< pp @selfNonOptim2 +%%] + +------------------------------------------------------------------------- +-- Error +------------------------------------------------------------------------- + +%%[1 ag +SEM Jd + | Ats lhs . errL = @eqnErrs +%%] diff --git a/src/TrfAS2/GenLaTeX.cag b/src/TrfAS2/GenLaTeX.cag new file mode 100644 --- /dev/null +++ b/src/TrfAS2/GenLaTeX.cag @@ -0,0 +1,112 @@ +------------------------------------------------------------------------- +-- Generate LaTeX's from attr bindings +------------------------------------------------------------------------- + +%%[1 hs module (TrfAS2.GenLaTeX) +%%] + +%%[1 hs export (as2LaTeX) +%%] + +%%[1 hs import (Data.Maybe, Data.Char, Data.List, qualified Data.Set as Set, qualified Data.Map as Map, UHC.Util.Utils) +%%] + +%%[1 hs import (Opts, Err, Common, KeywParser( propsSynInhMp ), Expr.Utils, ARule.Utils, FmGam, RwExprGam, ECnstrGam) +%%] + +%%[1 hs import (AbsSyn.AbsSyn2, Admin, Utils) +%%] + +%%[1 hs import (UHC.Util.Pretty) +%%] + +------------------------------------------------------------------------- +-- Inclusion of split off parts +------------------------------------------------------------------------- + +%%[1 ag import ({AbsSyn/AbsSyn2AG}, {AbsSyn/CommonAG}, {AS2/Opts}) +%%] + +%%[1 ag import ({TrfAS2/CommonAG}, {Expr/AbsSynAG}, {Expr/SelfAG}) +%%] + +%%[1 ag import ({ARule/AbsSynAG}, {ARule/SelfAG}) +%%] + +------------------------------------------------------------------------- +-- Interfacing to AST +------------------------------------------------------------------------- + +%%[1 ag +WRAPPER AGItf +%%] + +%%[1 hs +as2LaTeX :: Opts -> DtInvGam -> ScGam Expr -> FmGam Expr -> RwExprGam -> Decls -> (Decls,PP_Doc,[Err]) +as2LaTeX o _ scg fmg rwg r + = (self_Syn_AGItf r2,ppDbg_Syn_AGItf r2,errL_Syn_AGItf r2) + where r1 = sem_AGItf (AGItf_AGItf r) + r2 = wrap_AGItf r1 + (Inh_AGItf {opts_Inh_AGItf = o, fmGam_Inh_AGItf = fmg, rwGam_Inh_AGItf = rwg, scGam_Inh_AGItf = scg}) +%%] + +------------------------------------------------------------------------- +-- Context: ruleset info +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllVw [ rsDescr: String | | ] + +SEM RsVwDecl + | Rs loc . rsDescr = @descr +%%] + +------------------------------------------------------------------------- +-- Names of rules +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllRl [ | | rlFullNmL USE {++} {[]}: {[Nm]} ] + +SEM RlDecl + | Rl lhs . rlFullNmL = [@fullNm] + | LTXAlias lhs . rlFullNmL = [@fullAliasNm] +%%] + +------------------------------------------------------------------------- +-- Replica +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllVw [ | | rlVwDecls, figVwDecls USE {++} {[]}: {[VwDecl]} ] + +SEM RsVwDecl + | Rs lhs . self = RsVwDecl_Rs @nm @scNm @descr (@vwDecls.rlVwDecls ++ @vwDecls.figVwDecls) + +SEM VwDecl + | Vw lhs . (rlVwDecls,figVwDecls) + = let scMetaNm = @fullNm `nmApd` Nm "scheme" + (scInfo,vwScInfo) + = maybe (panic "VwDecl_Vw: scInfo") id + $ scVwGamLookup @lhs.rsScNm @vwNm @lhs.scGam + eScm + = exprSubst (@lhs.opts {optSubstOnce=True}) @lhs.fmGam + . jdGamFmExpr @lhs.fm . vwscJdShpGam + $ vwScInfo + in ( [ VwDecl_LTX @nm scMetaNm eScm @rlDecls.self ] + , [ VwDecl_LTXFig @nm @fullNm scMetaNm @lhs.rsDescr @rlDecls.rlFullNmL ] + ) + +SEM RlDecl + | Rl lhs . self = let + in RlDecl_LTX @fullNm @rlNm @lhs.vwNm @pos @preJds.self @postJds.self + +SEM Jd + | Expr loc . exprRW = exprRewrite (@lhs.opts {optSubstFullNm=False}) @lhs.fmGam @lhs.rwGam emptyGam @expr.self + lhs . self = Jd_LTX @nm @scNm @exprRW @isSmall + +{- + lhs . self = Jd_LTX @nm @scNm (exprSubst (@lhs.opts {optSubstFullNm=False}) @lhs.fmGam @expr.self) +-} + +%%] diff --git a/src/Ty/AbsSynAG.cag b/src/Ty/AbsSynAG.cag new file mode 100644 --- /dev/null +++ b/src/Ty/AbsSynAG.cag @@ -0,0 +1,29 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- Ty AST +------------------------------------------------------------------------- + +------------------------------------------------------------------------- +-- Interfacing +------------------------------------------------------------------------- + +DATA AGTyItf + | AGItf ty : Ty + +------------------------------------------------------------------------- +-- Ty +------------------------------------------------------------------------- + +DATA Ty + | Con nm : {Nm} + | App lTy : Ty + rTy : Ty + +------------------------------------------------------------------------- +-- Sets +------------------------------------------------------------------------- + +SET AllTy = Ty + +%%] diff --git a/src/Ty/PrettyPrint.cag b/src/Ty/PrettyPrint.cag new file mode 100644 --- /dev/null +++ b/src/Ty/PrettyPrint.cag @@ -0,0 +1,39 @@ +------------------------------------------------------------------------- +-- PP for Ty +------------------------------------------------------------------------- + +%%[1 hs module (Ty.PrettyPrint) +%%] + +%%[1 hs export(ppTy) +%%] + +%%[1 hs import(UHC.Util.Pretty) +%%] + +%%[1 hs import(Common) +%%] + +%%[1 hs import(Ty.Ty) +%%] + +%%[1 ag import ({Ty/AbsSynAG}, {Ty/PrettyPrintAG}) +%%] + +%%[1 ag +WRAPPER AGTyItf +%%] + +%%[1 hs + +ppTy :: Ty -> PP_Doc +ppTy e + = pp_Syn_AGTyItf r2 + where r1 = sem_AGTyItf (AGTyItf_AGItf e) + r2 = wrap_AGTyItf r1 + (Inh_AGTyItf ) + +instance PP Ty where + pp = ppTy + +%%] diff --git a/src/Ty/PrettyPrintAG.cag b/src/Ty/PrettyPrintAG.cag new file mode 100644 --- /dev/null +++ b/src/Ty/PrettyPrintAG.cag @@ -0,0 +1,14 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- PP for Ty +------------------------------------------------------------------------- + +ATTR AllTy AGTyItf [ | | pp USE {>-<} {empty} : PP_Doc ] + +SEM Ty + | App lhs . pp = @lTy.pp + >#< @rTy.pp + | Con lhs . pp = pp @nm + +%%] diff --git a/src/Ty/SelfAG.cag b/src/Ty/SelfAG.cag new file mode 100644 --- /dev/null +++ b/src/Ty/SelfAG.cag @@ -0,0 +1,8 @@ +------------------------------------------------------------------------- +-- Self +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllTy [ | | self: SELF ] +ATTR AGTyItf [ | | self: Ty ] +%%] diff --git a/src/Ty/Ty.cag b/src/Ty/Ty.cag new file mode 100644 --- /dev/null +++ b/src/Ty/Ty.cag @@ -0,0 +1,38 @@ +------------------------------------------------------------------------- +-- Haskell interface to Ty AST +------------------------------------------------------------------------- + +%%[1 hs module (Ty.Ty) +%%] + +%%[1 hs export(AGTyItf(..), Ty(..), tyUnk, tyTopNm) +%%] + +%%[1 hs import(Common) +%%] + +%%[1 ag import({Ty/AbsSynAG}) +%%] + +%%[1 ag +DERIVING AllTy: Eq,Ord,Show +%%] + +------------------------------------------------------------------------- +-- Top name +------------------------------------------------------------------------- + +%%[1 hs +tyTopNm :: Ty -> Nm +tyTopNm (Ty_Con n) = n +tyTopNm _ = nmUnk +%%] + +------------------------------------------------------------------------- +-- Misc +------------------------------------------------------------------------- + +%%[1 hs +tyUnk :: Ty +tyUnk = Ty_Con nmUnk +%%] diff --git a/src/Ty/Utils.chs b/src/Ty/Utils.chs new file mode 100644 --- /dev/null +++ b/src/Ty/Utils.chs @@ -0,0 +1,19 @@ +%%[1 hs module (Ty.Utils) +%%] + +%%[1 hs export (module Ty.Ty, module Ty.PrettyPrint) +%%] + +%%[1 hs import (Ty.Ty) +%%] + +%%[1 hs import (Ty.PrettyPrint) +%%] + +------------------------------------------------------------------------- +-- Interface to all Ty transformations and other utilities +------------------------------------------------------------------------- + +%%[1 hs + +%%] diff --git a/src/Utils.chs b/src/Utils.chs new file mode 100644 --- /dev/null +++ b/src/Utils.chs @@ -0,0 +1,56 @@ +-- $Id: EHTyFitsIn.chs 214 2005-05-28 17:52:29Z atze $ + +%%[1 hs module (Utils) +%%] + +%%[1 hs export (jdGamFmExpr, rlLtxGamTranspose, gamTranspose, sc2DATA, rl2SEM) +%%] + +%%[1 hs import (qualified Data.Map as Map, Common, Expr.Expr, FmGam, JdShpGam, Admin) +%%] + +%%[1 hs + +------------------------------------------------------------------------- +-- Misc +------------------------------------------------------------------------- + +jdGamFmExpr :: FmKind -> JdShpGam Expr -> Expr +jdGamFmExpr k = fkGamLookup exprUnk jdshExpr [k,FmSpec] + +------------------------------------------------------------------------- +-- Transpose gam of gam +------------------------------------------------------------------------- + +gamTranspose + :: Ord k => + (i -> Gam k v,k -> k -> i -> v -> i') + -> Gam k i -> Gam k (Gam k i') +gamTranspose (getG,mkI) g + = gamFromAssocsWith gamUnion [ (k2,gamSingleton k1 (mkI k1 k2 v1 v2)) | (k1,v1) <- gamAssocsShadow g, (k2,v2) <- gamAssocsShadow (getG v1) ] + +rlLtxGamTranspose :: Ord k => Gam k (Gam k (n,v)) -> Gam k (Gam k (n,v)) +rlLtxGamTranspose g + = gamFromAssocsWith gamUnion [ (v,gamSingleton r (n,d)) | (r,vm) <- gamAssocsShadow g, (v,(n,d)) <- gamAssocsShadow vm ] + +------------------------------------------------------------------------- +-- RulerAdmin: AG name info +------------------------------------------------------------------------- + +sc2DATA :: ScInfo e -> DtInvGam -> Nm +sc2DATA si dg + = case scMbAGStr si of + Just s -> Nm s + Nothing -> case gamLookup (scNm si) dg of + Just i -> dtiAGNm i + Nothing -> scNm si + +rl2SEM :: RlInfo e -> DtInvGam -> Nm -> Nm -> Nm -> Nm +rl2SEM rlInfo dg scNm rlNm vwNm + = case rlMbAGStr rlInfo of + Just s -> Nm s + Nothing -> case dtVwRlInvGamLookup scNm vwNm rlNm dg of + Just (_,_,i) -> daiAGNm i + Nothing -> rlNm + +%%] diff --git a/src/Version.chs b/src/Version.chs new file mode 100644 --- /dev/null +++ b/src/Version.chs @@ -0,0 +1,23 @@ +------------------------------------------------------------------------- +-- Version of program +-- $Id: ede1e5939ba7b49790aaf6b662c890496aa8dc70 $ +------------------------------------------------------------------------- + +%%[1 hs module (Version) +import Paths_ruler (version) +import Data.Version (showVersion) +%%] + +%%[1 hs export (versionInfo, versionDist, versionSvn) +%%] + +------------------------------------------------------------------------- +-- Version info +------------------------------------------------------------------------- + +%%[1 hs +versionSvn = "$Id: ede1e5939ba7b49790aaf6b662c890496aa8dc70 $" +versionDist = showVersion version +versionProg = "ruler" +versionInfo = versionProg ++ "(" ++ versionDist ++ ")" ++ ", " ++ versionSvn +%%] diff --git a/src/ViewSel/AbsSynAG.cag b/src/ViewSel/AbsSynAG.cag new file mode 100644 --- /dev/null +++ b/src/ViewSel/AbsSynAG.cag @@ -0,0 +1,53 @@ +%%[1 ag + +------------------------------------------------------------------------- +-- Interfacing +------------------------------------------------------------------------- + +DATA AGViewSelItf + | AGItf viewSel : ViewSel + +DATA AGViewSelsItf + | AGItf viewSels : ViewSels + +DATA AGRlSelItf + | AGItf rlSel : RlSel + +------------------------------------------------------------------------- +-- View selection +------------------------------------------------------------------------- + +DATA ViewSel + | All + | View nm : {Nm} + | Renamed nmNew : {Nm} + nm : {Nm} + | Range vwFr : ViewSel + vwTo : ViewSel + +TYPE ViewSels = [ViewSel] + +SET AllViewSel = ViewSel ViewSels + +------------------------------------------------------------------------- +-- Rule selection +------------------------------------------------------------------------- + +DATA RlSel + | Sel vwSel : ViewSels + rsSel : NmSel + rlSel : NmSel + +SET AllRlSel = RlSel + +------------------------------------------------------------------------- +-- Nm selection +------------------------------------------------------------------------- + +DATA NmSel + | All + | Nms nms : {[Nm]} + +SET AllNmSel = NmSel + +%%] diff --git a/src/ViewSel/DpdGrAG.cag b/src/ViewSel/DpdGrAG.cag new file mode 100644 --- /dev/null +++ b/src/ViewSel/DpdGrAG.cag @@ -0,0 +1,7 @@ +------------------------------------------------------------------------- +-- View dpd graph +------------------------------------------------------------------------- + +%%[1 ag +ATTR AGViewSelItf AGViewSelsItf AGRlSelItf AllViewSel AllRlSel [ vwDpdGr: {DpdGr Nm} | | ] +%%] diff --git a/src/ViewSel/NmS.cag b/src/ViewSel/NmS.cag new file mode 100644 --- /dev/null +++ b/src/ViewSel/NmS.cag @@ -0,0 +1,37 @@ +------------------------------------------------------------------------- +-- Interfacing to ViewSel: names +------------------------------------------------------------------------- + +%%[1 hs module (ViewSel.NmS) +%%] + +%%[1 hs export (viewSelsNmS, viewSelNmS) +%%] + +%%[1 hs import (qualified Data.Set as Set, UHC.Util.Nm, UHC.Util.DependencyGraph, ViewSel.ViewSel) +%%] + +%%[1 ag import ({ViewSel/AbsSynAG}, {ViewSel/DpdGrAG}, {ViewSel/NmSAG}) +%%] + +%%[1 ag +WRAPPER AGViewSelItf AGViewSelsItf +%%] + +%%[1 hs +viewSelNmS :: DpdGr Nm -> ViewSel -> Set.Set Nm +viewSelNmS vwDpdGr vs + = vwSelNmS_Syn_AGViewSelItf r2 + where r1 = sem_AGViewSelItf (AGViewSelItf_AGItf vs) + r2 = wrap_AGViewSelItf r1 + (Inh_AGViewSelItf {vwDpdGr_Inh_AGViewSelItf = vwDpdGr + }) + +viewSelsNmS :: DpdGr Nm -> ViewSels -> Set.Set Nm +viewSelsNmS vwDpdGr vs + = vwSelNmS_Syn_AGViewSelsItf r2 + where r1 = sem_AGViewSelsItf (AGViewSelsItf_AGItf vs) + r2 = wrap_AGViewSelsItf r1 + (Inh_AGViewSelsItf {vwDpdGr_Inh_AGViewSelsItf = vwDpdGr + }) +%%] diff --git a/src/ViewSel/NmSAG.cag b/src/ViewSel/NmSAG.cag new file mode 100644 --- /dev/null +++ b/src/ViewSel/NmSAG.cag @@ -0,0 +1,14 @@ +------------------------------------------------------------------------- +-- View selection +------------------------------------------------------------------------- + +%%[1 ag +ATTR AGViewSelsItf AGViewSelItf AllViewSel [ | | vwSelNmS USE {`Set.union`} {Set.empty}: {Set.Set Nm} ] + +SEM ViewSel + | View Renamed lhs . vwSelNmS = Set.singleton @nm + | All lhs . vwSelNmS = dgVertices @lhs.vwDpdGr + | Range lhs . vwSelNmS = let toS = Set.fold (\n r -> dgReachableFrom @lhs.vwDpdGr n `Set.union` r) Set.empty @vwTo.vwSelNmS + frSL = [ dgReachableTo @lhs.vwDpdGr n | n <- Set.toList @vwFr.vwSelNmS ] + in Set.filter (\n -> any (\s -> n `Set.member` s) frSL) toS +%%] diff --git a/src/ViewSel/Parser.chs b/src/ViewSel/Parser.chs new file mode 100644 --- /dev/null +++ b/src/ViewSel/Parser.chs @@ -0,0 +1,37 @@ +------------------------------------------------------------------------- +-- ViewSel parser +------------------------------------------------------------------------- + +%%[1 hs module (ViewSel.Parser) +%%] + +%%[1 hs export (module KeywParser, module NmParser, pViewSel, pViewSels, pNmSel, pRlSel) +%%] + +%%[1 hs import (qualified Data.Set as Set, qualified Data.Map as Map, UU.Parsing, Scanner, UHC.Util.ParseUtils, UHC.Util.Nm) +%%] + +%%[1 hs import (KeywParser, NmParser, ViewSel.ViewSel) +%%] + +------------------------------------------------------------------------- +-- Parser +------------------------------------------------------------------------- + +%%[1 hs +pViewSel :: (IsParser p Token) => p ViewSel +pViewSel + = pV ((flip ViewSel_Range) <$ pKey "-" <*> pV) + where pV = ViewSel_View <$> pNmVw <|> ViewSel_All <$ pKey "*" + <|> pParens (ViewSel_Renamed <$> (foldr1 nmStrApd <$> pList1 pNmVw) <* pKey "=" <*> pNmVw) + + +pViewSels :: (IsParser p Token) => p ViewSels +pViewSels = pListSep pComma pViewSel + +pNmSel :: (IsParser p Token) => p NmSel +pNmSel = NmSel_All <$ pKey "*" <|> NmSel_Nms <$> pList pNm + +pRlSel :: (IsParser p Token) => p RlSel +pRlSel = RlSel_Sel <$> pParens pViewSels <* pKey "." <*> pParens pNmSel <* pKey "." <*> pParens pNmSel +%%] diff --git a/src/ViewSel/PrettyPrint.cag b/src/ViewSel/PrettyPrint.cag new file mode 100644 --- /dev/null +++ b/src/ViewSel/PrettyPrint.cag @@ -0,0 +1,52 @@ +------------------------------------------------------------------------- +-- Interfacing to ViewSel: pretty print +------------------------------------------------------------------------- + +%%[1 hs module (ViewSel.PrettyPrint) +%%] + +%%[1 hs export (ppViewSel, ppViewSels) +%%] + +%%[1 hs import (UHC.Util.Pretty, UHC.Util.Nm, ViewSel.ViewSel) +%%] + +%%[1 ag import ({ViewSel/AbsSynAG}) +%%] + +%%[1 ag +WRAPPER AGViewSelItf AGViewSelsItf +%%] + +%%[1 hs +ppViewSel :: ViewSel -> PP_Doc +ppViewSel vs + = pp_Syn_AGViewSelItf r2 + where r1 = sem_AGViewSelItf (AGViewSelItf_AGItf vs) + r2 = wrap_AGViewSelItf r1 (Inh_AGViewSelItf) + +ppViewSels :: ViewSels -> PP_Doc +ppViewSels vs + = pp_Syn_AGViewSelsItf r2 + where r1 = sem_AGViewSelsItf (AGViewSelsItf_AGItf vs) + r2 = wrap_AGViewSelsItf r1 (Inh_AGViewSelsItf) + +instance PP ViewSel where + pp = ppViewSel +%%] + +------------------------------------------------------------------------- +-- Pretty print +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllViewSel AGViewSelItf AGViewSelsItf [ | | pp USE {>-<} {empty} : PP_Doc ] + +SEM ViewSel + | All lhs . pp = pp "*" + | View lhs . pp = pp @nm + | Range lhs . pp = @vwFr.pp >#< ".." >#< @vwTo.pp + +SEM ViewSels + | Cons lhs . pp = @hd.pp >|< "," >#< @tl.pp +%%] diff --git a/src/ViewSel/RlIsSel.cag b/src/ViewSel/RlIsSel.cag new file mode 100644 --- /dev/null +++ b/src/ViewSel/RlIsSel.cag @@ -0,0 +1,63 @@ +------------------------------------------------------------------------- +-- Interfacing to ViewSel: RlSel is selected? +------------------------------------------------------------------------- + +%%[1 hs module (ViewSel.RlIsSel) +%%] + +%%[1 hs export (rlSelIsSel, RlSelIsSel) +%%] + +%%[1 hs import (qualified Data.Set as Set, UHC.Util.Nm, Common, UHC.Util.DependencyGraph, ViewSel.ViewSel) +%%] + +%%[1 ag import ({ViewSel/AbsSynAG}, {ViewSel/DpdGrAG}, {ViewSel/NmSAG}) +%%] + +%%[1 ag +WRAPPER AGRlSelItf +%%] + +%%[1 hs +wrapRlSel :: DpdGr Nm -> RlSel -> Syn_AGRlSelItf +wrapRlSel vwDpdGr vs + = let r1 = sem_AGRlSelItf (AGRlSelItf_AGItf vs) + in wrap_AGRlSelItf r1 + (Inh_AGRlSelItf {vwDpdGr_Inh_AGRlSelItf = vwDpdGr + }) + +rlSelIsSel :: DpdGr Nm -> RlSel -> RlSelIsSel +rlSelIsSel vwDpdGr rs + = rlSelIsSel_Syn_AGRlSelItf r + where r = wrapRlSel vwDpdGr rs +%%] + +------------------------------------------------------------------------- +-- Is it selected? +------------------------------------------------------------------------- + +%%[1 hs +type RlSelIsSel = Nm -> Nm -> Nm -> Bool +%%] + +%%[1 ag +ATTR RlSel AGRlSelItf [ | | rlSelIsSel: RlSelIsSel ] + +SEM RlSel + | Sel lhs . rlSelIsSel = \nVw nRs nRl + -> (nVw == nmAny || nVw `Set.member` @vwSel.vwSelNmS) + && (nRs == nmAny || @rsSel.isSel nRs) + && (nRl == nmAny || @rlSel.isSel nRl) +%%] + +------------------------------------------------------------------------- +-- Is name selected? +------------------------------------------------------------------------- + +%%[1 ag +ATTR NmSel [ | | isSel: {Nm -> Bool} ] + +SEM NmSel + | All lhs . isSel = const True + | Nms lhs . isSel = (`elem` @nms) +%%] diff --git a/src/ViewSel/RlRnm.cag b/src/ViewSel/RlRnm.cag new file mode 100644 --- /dev/null +++ b/src/ViewSel/RlRnm.cag @@ -0,0 +1,52 @@ +------------------------------------------------------------------------- +-- Interfacing to ViewSel: RlSel renaming +------------------------------------------------------------------------- + +%%[1 hs module (ViewSel.RlRnm) +%%] + +%%[1 hs export (rlSelRnmM, rsSelMapVwNm) +%%] + +%%[1 hs import (qualified Data.Map as Map, UHC.Util.Nm, ViewSel.ViewSel) +%%] + +%%[1 ag import ({ViewSel/AbsSynAG}) +%%] + +%%[1 ag +WRAPPER AGRlSelItf +%%] + +%%[1 hs +wrapRlSel :: RlSel -> Syn_AGRlSelItf +wrapRlSel vs + = let r1 = sem_AGRlSelItf (AGRlSelItf_AGItf vs) + in wrap_AGRlSelItf r1 + (Inh_AGRlSelItf) + +rlSelRnmM :: RlSel -> Map.Map Nm Nm +rlSelRnmM rs + = vwRnmM_Syn_AGRlSelItf r + where r = wrapRlSel rs +%%] + +------------------------------------------------------------------------- +-- Mapping of Ruler view name to other +------------------------------------------------------------------------- + +%%[1 hs +rsSelMapVwNm :: Maybe RlSel -> Nm -> Nm +rsSelMapVwNm mbRlSel vNm = maybe vNm (maybe vNm id . Map.lookup vNm . rlSelRnmM) mbRlSel +%%] + +------------------------------------------------------------------------- +-- View renaming +------------------------------------------------------------------------- + +%%[1 ag +ATTR AGRlSelItf AllViewSel AllRlSel [ | | vwRnmM USE {`Map.union`} {Map.empty}: {Map.Map Nm Nm} ] + +SEM ViewSel + | Renamed lhs . vwRnmM = Map.singleton @nm @nmNew +%%] diff --git a/src/ViewSel/Self.cag b/src/ViewSel/Self.cag new file mode 100644 --- /dev/null +++ b/src/ViewSel/Self.cag @@ -0,0 +1,55 @@ +------------------------------------------------------------------------- +-- Interfacing to ViewSel: self/copy/clone +------------------------------------------------------------------------- + +%%[1 hs module (ViewSel.Self) +%%] + +%%[1 hs export (viewSelsSelfT, rlSelSelfT) +%%] + +%%[1 hs import (UHC.Util.Nm, UHC.Util.DependencyGraph, ViewSel.ViewSel) +%%] + +%%[1 ag import ({ViewSel/AbsSynAG}) +%%] + +%%[1 ag +WRAPPER AGViewSelsItf +WRAPPER AGRlSelItf +%%] + +%%[1 hs +wrapViewSelsT :: T_ViewSels -> Syn_AGViewSelsItf +wrapViewSelsT vs + = let r1 = sem_AGViewSelsItf_AGItf vs + in wrap_AGViewSelsItf r1 + (Inh_AGViewSelsItf) + +viewSelsSelfT :: ViewSels -> ViewSels +viewSelsSelfT vs + = self_Syn_AGViewSelsItf r + where r = wrapViewSelsT (sem_ViewSels vs) + +wrapRlSelT :: T_RlSel -> Syn_AGRlSelItf +wrapRlSelT vs + = let r1 = sem_AGRlSelItf_AGItf vs + in wrap_AGRlSelItf r1 + (Inh_AGRlSelItf) + +rlSelSelfT :: RlSel -> RlSel +rlSelSelfT vs + = self_Syn_AGRlSelItf r + where r = wrapRlSelT (sem_RlSel vs) + +%%] + +------------------------------------------------------------------------- +-- Self +------------------------------------------------------------------------- + +%%[1 ag +ATTR AllViewSel AllRlSel AllNmSel [ | | self: SELF ] +ATTR AGViewSelsItf [ | | self: ViewSels ] +ATTR AGRlSelItf [ | | self: RlSel ] +%%] diff --git a/src/ViewSel/Utils.chs b/src/ViewSel/Utils.chs new file mode 100644 --- /dev/null +++ b/src/ViewSel/Utils.chs @@ -0,0 +1,16 @@ +------------------------------------------------------------------------- +-- Interface to all ViewSel transformations and other utilities +------------------------------------------------------------------------- + +%%[1 hs module (ViewSel.Utils) +%%] + +%%[1 hs export (module ViewSel.ViewSel, module ViewSel.NmS, module ViewSel.RlRnm, module ViewSel.RlIsSel, module ViewSel.PrettyPrint) +%%] + +%%[1 hs import (ViewSel.ViewSel, ViewSel.NmS, ViewSel.RlRnm, ViewSel.RlIsSel, ViewSel.PrettyPrint) +%%] + +%%[1 hs + +%%] diff --git a/src/ViewSel/ViewSel.cag b/src/ViewSel/ViewSel.cag new file mode 100644 --- /dev/null +++ b/src/ViewSel/ViewSel.cag @@ -0,0 +1,16 @@ +------------------------------------------------------------------------- +-- Haskell interface to ViewSel AST +------------------------------------------------------------------------- + +%%[1 hs module (ViewSel.ViewSel) +%%] + +%%[1 hs import (UHC.Util.Nm) +%%] + +%%[1 ag import ({ViewSel/AbsSynAG}) +%%] + +%%[1 ag +DERIVING AllViewSel AllRlSel AllNmSel: Show +%%] diff --git a/src/WrKindGam.chs b/src/WrKindGam.chs new file mode 100644 --- /dev/null +++ b/src/WrKindGam.chs @@ -0,0 +1,41 @@ +------------------------------------------------------------------------- +-- WrKind Gamma +------------------------------------------------------------------------- + +%%[1 hs module (WrKindGam) +%%] + +%%[1 hs export (module Gam, WrKindInfo(..), WrKindGam, wrKindGam) +%%] + +%%[1 hs import (qualified Data.Map as Map, UHC.Util.Pretty, Common, Gam) +%%] + +------------------------------------------------------------------------- +-- WrKind +------------------------------------------------------------------------- + +%%[1 hs + +data WrKindInfo + = WrKindInfo + { wkBegCmd :: Nm + , wkEndCmd :: Nm + } + +instance Show WrKindInfo where + show _ = "WrKindInfo" + +instance PP WrKindInfo where + pp i = pp "WK" + +type WrKindGam = Gam WrKind WrKindInfo + +wrKindGam :: WrKindGam +wrKindGam + = gamFromAssocs + [ (WrIsChanged,WrKindInfo nmCmdBegChng nmCmdEndChng) + , (WrIsSame ,WrKindInfo nmCmdBegSame nmCmdEndSame) + ] + +%%]