packages feed

ruler (empty) → 0.4.0.0

raw patch · 103 files changed

+9497/−0 lines, 103 filesdep +basedep +containersdep +mtlbuild-type:Customsetup-changed

Dependencies added: base, containers, mtl, shuffle, uhc-util, uuagc, uuagc-cabal, uulib

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -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
+ demo/Makefile view
@@ -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)
+ demo/RulerDemoMain.cag view
@@ -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+%%]++
+ demo/RulerDemoUtils.chs view
@@ -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  = "<ERR:" >#< 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+%%]+
+ demo/rulerDemoRL.crl2 view
@@ -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)+%%]+
+ demo/tst1 view
@@ -0,0 +1,2 @@+let i = 5+in  i
+ demo/tst2 view
@@ -0,0 +1,7 @@+let id = \x -> x+in+let v1 = id 3+in+let v2 = id id+in  v1+
+ demo/tst3 view
@@ -0,0 +1,4 @@+let app = \f -> \a -> f a+in+let v = app 3 j+in  v
+ demo/tst5 view
@@ -0,0 +1,4 @@+let  id = \x -> x+in   let  v1 = id 3+     in   let  v2 = id id+          in   v2 v1
+ ruler.cabal view
@@ -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
+ src/ARule/ARule.cag view
@@ -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++%%]
+ src/ARule/AVarRename.cag view
@@ -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++%%]
+ src/ARule/AbsSynAG.cag view
@@ -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++%%]
+ src/ARule/CopyRuleNmAG.cag view
@@ -0,0 +1,9 @@+%%[1 ag++-------------------------------------------------------------------------+-- Copy Rule nms+-------------------------------------------------------------------------++ATTR AGARuleItf [ croNmL: {[Nm]} | | ]++%%]
+ src/ARule/ElimCopyRule.cag view
@@ -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++%%]
+ src/ARule/ElimWildcAssign.cag view
@@ -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++%%]
+ src/ARule/EqnDest1NmAG.cag view
@@ -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++%%]
+ src/ARule/FmGamAG.cag view
@@ -0,0 +1,9 @@+-------------------------------------------------------------------------+-- FmGam+-------------------------------------------------------------------------++%%[1 ag++ATTR AGARuleItf AllARule [ fmGam: {FmGam Expr} | | ]++%%]
+ src/ARule/InCompDestAG.cag view
@@ -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++%%]
+ src/ARule/OptsAG.cag view
@@ -0,0 +1,9 @@+-------------------------------------------------------------------------+-- Global info+-------------------------------------------------------------------------++%%[1 ag++ATTR AllARule AGARuleItf [ opts: {Opts} | | ]++%%]
+ src/ARule/PatternUniq.cag view
@@ -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++%%]
+ src/ARule/PrettyPrint.cag view
@@ -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++%%]
+ src/ARule/PrettyPrintAG.cag view
@@ -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++%%]
+ src/ARule/RwSubst.cag view
@@ -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+%%]
+ src/ARule/SelfAG.cag view
@@ -0,0 +1,10 @@+%%[1 ag++-------------------------------------------------------------------------+-- Self+-------------------------------------------------------------------------++ATTR AllARule [ | | self: SELF ]+ATTR AGARuleItf [ | | self: ARule ]++%%]
+ src/ARule/Utils.chs view
@@ -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++%%]
+ src/AS1/GenAS2.cag view
@@ -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 []++%%]
+ src/AS1/Imports.cag view
@@ -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+%%]
+ src/AS1/Misc.cag view
@@ -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++%%]
+ src/AS1/Pretty.cag view
@@ -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++%%]
+ src/AS1/RlSel.cag view
@@ -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++%%]
+ src/AS1/SchemeDpd.cag view
@@ -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++%%]
+ src/AS1/ViewDpd.cag view
@@ -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)++%%]
+ src/AS2/Opts.cag view
@@ -0,0 +1,7 @@+-------------------------------------------------------------------------+-- Global info+-------------------------------------------------------------------------++%%[1 ag+ATTR AllAS2 AGItf [ opts: {Opts} | | ]+%%]
+ src/AS2/Pretty.cag view
@@ -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+%%]
+ src/AbsSyn/AbsSyn1.cag view
@@ -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})+%%]
+ src/AbsSyn/AbsSyn1AG.cag view
@@ -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++%%]
+ src/AbsSyn/AbsSyn2.cag view
@@ -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+%%]
+ src/AbsSyn/AbsSyn2AG.cag view
@@ -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++%%]
+ src/AbsSyn/CommonAG.cag view
@@ -0,0 +1,12 @@+-------------------------------------------------------------------------+-- Ruler AST, common between passes+-------------------------------------------------------------------------++-------------------------------------------------------------------------+-- Interfacing+-------------------------------------------------------------------------++%%[1 ag+DATA AGItf+  | AGItf               decls       : Decls+%%]
+ src/Admin.chs view
@@ -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++%%]
+ src/AttrProps.chs view
@@ -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++%%]
+ src/Common.chs view
@@ -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)++%%]
+ src/Config.chs view
@@ -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+  ]+%%]
+ src/ECnstrGam.chs view
@@ -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+%%]
+ src/Err.chs view
@@ -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++%%]
+ src/Expr/AbsSynAG.cag view
@@ -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+++%%]
+ src/Expr/CoGam.cag view
@@ -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++%%]
+ src/Expr/Expr.cag view
@@ -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+%%]
+ src/Expr/FmGamAG.cag view
@@ -0,0 +1,9 @@+%%[1 ag++-------------------------------------------------------------------------+-- FmGam+-------------------------------------------------------------------------++ATTR AllExprButANm AGExprItf [ fmGam: {FmGam Expr} | | ]++%%]
+ src/Expr/IsRw.cag view
@@ -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'+%%]
+ src/Expr/IsRwAG.cag view
@@ -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++%%]
+ src/Expr/LaTeX.cag view
@@ -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 })+%%]
+ src/Expr/LaTeXAG.cag view
@@ -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++%%]
+ src/Expr/NmS.cag view
@@ -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)+%%]
+ src/Expr/NmSAG.cag view
@@ -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++%%]
+ src/Expr/OptsAG.cag view
@@ -0,0 +1,7 @@+-------------------------------------------------------------------------+-- Global info+-------------------------------------------------------------------------++%%[1 ag+ATTR AllExpr AGExprItf [ opts: {Opts} | | ]+%%]
+ src/Expr/PrettyPrintAG.cag view
@@ -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++%%]
+ src/Expr/RwExprGamAG.cag view
@@ -0,0 +1,7 @@+-------------------------------------------------------------------------+-- RwExprGam+-------------------------------------------------------------------------++%%[1 ag+ATTR AllExprButANm AGExprItf [ rwGam: RwExprGam | | ]+%%]
+ src/Expr/SelfAG.cag view
@@ -0,0 +1,8 @@+-------------------------------------------------------------------------+-- Self+-------------------------------------------------------------------------++%%[1 ag+ATTR AllExpr [ | | self: SELF ]+ATTR AGExprItf [ | | self: Expr ]+%%]
+ src/Expr/ToAEqn.chs view
@@ -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)]++%%]
+ src/Expr/Utils.chs view
@@ -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++%%]
+ src/FmGam.chs view
@@ -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))++%%]
+ src/FmGamAG.cag view
@@ -0,0 +1,8 @@+-------------------------------------------------------------------------+-- FmGam+-------------------------------------------------------------------------++%%[1 ag+ATTR AllDecl [ fmGam: {FmGam Expr} | | ]+ATTR AGItf [ fmGam: {FmGam Expr} | | ]+%%]
+ src/Gam.chs view
@@ -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++%%]
+ src/JdShpGam.chs view
@@ -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++%%]
+ src/KeywParser.chs view
@@ -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)++%%]
+ src/LaTeXFmtUtils.chs view
@@ -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 >-< "%%]"++%%]
+ src/Main1AG.cag view
@@ -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]+-}++%%]
+ src/Main2AG.cag view
@@ -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})+%%]
+ src/MkAdmin.chs view
@@ -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++%%]
+ src/NmParser.chs view
@@ -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+%%]
+ src/Opts.chs view
@@ -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 "<name>")+          "base name, default = 'rules'"+     , Option "c"  ["markchanges"]      (OptArg oMarkCh "<spec>")+          "mark changes between specified views (with --lhs2tex)"+          -- "mark changes between specified views (in combi with --lhs2tex, <spec>=*|<view name>|<view name>-<view name>)"+     , 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 "<path>")+          "search path, default empty"+     , Option ""   ["preamble"]         (OptArg oPreamble "yes|no")+          "include preamble, default=yes"+     , Option "s"  ["selrule"]          (OptArg oRlSel "<spec>")+          "select rules by specifying view(s), ruleset(s) and rule(s)"+          -- "select rules by specifying view(s), ruleset(s) and rule(s), <spec>=(*|<view name>|<view name>-<view name>).(*|<ruleset names>).(*|<rule names>)"+     , 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++%%]
+ src/Parser.chs view
@@ -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)++%%]
+ src/Ruler.chs view
@@ -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>","<stdin>",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>","<stdin>",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 ())+-}++%%]
+ src/RwExprGam.chs view
@@ -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)+%%]
+ src/Scanner.chs view
@@ -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 ]++%%]
+ src/ScannerMachine.chs view
@@ -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++%%]
+ src/SelParser.chs view
@@ -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++%%]
+ src/TrfAS2/CommonAG.cag view
@@ -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]} ]++%%]
+ src/TrfAS2/GenARule.cag view
@@ -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+%%]
+ src/TrfAS2/GenLaTeX.cag view
@@ -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)+-}++%%]
+ src/Ty/AbsSynAG.cag view
@@ -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++%%]
+ src/Ty/PrettyPrint.cag view
@@ -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++%%]
+ src/Ty/PrettyPrintAG.cag view
@@ -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++%%]
+ src/Ty/SelfAG.cag view
@@ -0,0 +1,8 @@+-------------------------------------------------------------------------+-- Self+-------------------------------------------------------------------------++%%[1 ag+ATTR AllTy [ | | self: SELF ]+ATTR AGTyItf [ | | self: Ty ]+%%]
+ src/Ty/Ty.cag view
@@ -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+%%]
+ src/Ty/Utils.chs view
@@ -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++%%]
+ src/Utils.chs view
@@ -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++%%]
+ src/Version.chs view
@@ -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+%%]
+ src/ViewSel/AbsSynAG.cag view
@@ -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++%%]
+ src/ViewSel/DpdGrAG.cag view
@@ -0,0 +1,7 @@+-------------------------------------------------------------------------+-- View dpd graph+-------------------------------------------------------------------------++%%[1 ag+ATTR AGViewSelItf AGViewSelsItf AGRlSelItf AllViewSel AllRlSel [ vwDpdGr: {DpdGr Nm} | | ]+%%]
+ src/ViewSel/NmS.cag view
@@ -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+                                   })+%%]
+ src/ViewSel/NmSAG.cag view
@@ -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+%%]
+ src/ViewSel/Parser.chs view
@@ -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+%%]
+ src/ViewSel/PrettyPrint.cag view
@@ -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+%%]
+ src/ViewSel/RlIsSel.cag view
@@ -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)+%%]
+ src/ViewSel/RlRnm.cag view
@@ -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+%%]
+ src/ViewSel/Self.cag view
@@ -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 ]+%%]
+ src/ViewSel/Utils.chs view
@@ -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++%%]
+ src/ViewSel/ViewSel.cag view
@@ -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+%%]
+ src/WrKindGam.chs view
@@ -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)+      ]++%%]