uuagc 0.9.7 → 0.9.10
raw patch · 10 files changed
+687/−612 lines, 10 filesdep +ghc-primdep ~base
Dependencies added: ghc-prim
Dependency ranges changed: base
Files
- src-derived/PrintErrorMessages.hs +1/−1
- src-derived/Transform.hs +176/−168
- src/Ag.hs +2/−2
- src/Options.hs +10/−0
- src/Parser.hs +374/−342
- src/Scanner.hs +99/−82
- src/TokenDef.hs +12/−11
- src/Version.hs +1/−1
- uuagc.cabal +11/−4
- uuagc.cabal-for-ghc-6.6 +1/−1
src-derived/PrintErrorMessages.hs view
@@ -24,7 +24,7 @@ isError opts (DupSynAttr _ _ _ ) = True isError opts (DupChild _ _ _ _ ) = False isError opts (DupRule _ _ _ _ _) = True-isError opts (DupSig _ _ _ ) = True+isError opts (DupSig _ _ _ ) = False isError opts (UndefNont _ ) = True isError opts (UndefAlt _ _ ) = True isError opts (UndefChild _ _ _ ) = True
src-derived/Transform.hs view
@@ -484,10 +484,10 @@ -- "Transform.ag"(line 517, column 8) _elemsOdefinedSets = Map.map fst _elemsIdefSets- -- "Transform.ag"(line 761, column 8)+ -- "Transform.ag"(line 769, column 8) _elemsOattrDecls = Map.empty- -- "Transform.ag"(line 800, column 9)+ -- "Transform.ag"(line 808, column 9) _allAttrDecls = if withSelf _lhsIoptions then foldr addSelf _elemsIattrDecls (Set.toList _allNonterminals )@@ -495,7 +495,7 @@ -- use rule "Transform.ag"(line 42, column 19) _lhsOblocks = _elemsIblocks- -- use rule "Transform.ag"(line 894, column 37)+ -- use rule "Transform.ag"(line 902, column 37) _lhsOmoduleDecl = _elemsImoduleDecl -- use rule "Transform.ag"(line 598, column 34)@@ -725,16 +725,16 @@ (let _lhsOuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) _lhsOerrors :: (Seq Error) _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes))- -- "Transform.ag"(line 769, column 15)+ -- "Transform.ag"(line 777, column 15) __tup1 = checkAttrs _lhsIallFields (Set.toList _lhsInts) _inherited _synthesized _lhsIattrDecls- -- "Transform.ag"(line 769, column 15)+ -- "Transform.ag"(line 777, column 15) (_attrDecls,_) = __tup1- -- "Transform.ag"(line 769, column 15)+ -- "Transform.ag"(line 777, column 15) (_,_errors) = __tup1- -- "Transform.ag"(line 771, column 15)+ -- "Transform.ag"(line 779, column 15) __tup2 = let splitAttrs xs = unzip [ ((n,makeType _lhsIallNonterminals t),(n,ud)) | (n,t,ud) <- xs@@ -744,16 +744,16 @@ (syn,uses2) = splitAttrs syn_ isUse (n,(e1,e2,_)) = not (null e1 || null e2) in (inh++chn,chn++syn, Map.fromList (Prelude.filter isUse (uses1++uses2)))- -- "Transform.ag"(line 771, column 15)+ -- "Transform.ag"(line 779, column 15) (_inherited,_,_) = __tup2- -- "Transform.ag"(line 771, column 15)+ -- "Transform.ag"(line 779, column 15) (_,_synthesized,_) = __tup2- -- "Transform.ag"(line 771, column 15)+ -- "Transform.ag"(line 779, column 15) (_,_,_useMap) = __tup2- -- "Transform.ag"(line 779, column 11)+ -- "Transform.ag"(line 787, column 11) _lhsOuseMap = Map.fromList (zip (Set.toList _lhsInts) (repeat _useMap)) -- use rule "Transform.ag"(line 40, column 19)@@ -1065,15 +1065,15 @@ _attrsIattrDecls :: (Map NontermIdent (Attributes, Attributes)) _attrsIerrors :: (Seq Error) _attrsIuseMap :: (Map NontermIdent (Map Identifier (String,String,String)))- -- "Transform.ag"(line 721, column 7)+ -- "Transform.ag"(line 729, column 7) _lhsOctxCollect = if null ctx_ then Map.empty else Map.fromList [(nt, ctx_) | nt <- Set.toList _namesInontSet]- -- "Transform.ag"(line 765, column 10)+ -- "Transform.ag"(line 773, column 10) _attrsOnts = _namesInontSet- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = Map.empty -- use rule "Transform.ag"(line 42, column 19)@@ -1103,22 +1103,22 @@ -- use rule "Transform.ag"(line 145, column 31) _lhsOcollectedUniques = []- -- use rule "Transform.ag"(line 742, column 33)+ -- use rule "Transform.ag"(line 750, column 33) _lhsOderivings = Map.empty -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = _namesIerrors Seq.<> _attrsIerrors- -- use rule "Transform.ag"(line 894, column 37)+ -- use rule "Transform.ag"(line 902, column 37) _lhsOmoduleDecl = mzero- -- use rule "Transform.ag"(line 694, column 37)+ -- use rule "Transform.ag"(line 702, column 37) _lhsOparamsCollect = Map.empty -- use rule "Transform.ag"(line 598, column 34) _lhsOpragmas = id- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = Map.empty -- use rule "Transform.ag"(line 458, column 32)@@ -1224,20 +1224,20 @@ [ (n, _altsIcollectedConstructorNames) | n <- Set.toList _namesInontSet ]- -- "Transform.ag"(line 698, column 7)+ -- "Transform.ag"(line 706, column 7) _lhsOparamsCollect = if null params_ then Map.empty else Map.fromList [(nt, params_) | nt <- Set.toList _namesInontSet]- -- "Transform.ag"(line 721, column 7)+ -- "Transform.ag"(line 729, column 7) _lhsOctxCollect = if null ctx_ then Map.empty else Map.fromList [(nt, ctx_) | nt <- Set.toList _namesInontSet]- -- "Transform.ag"(line 764, column 10)+ -- "Transform.ag"(line 772, column 10) _attrsOnts = _namesInontSet- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = Map.empty -- use rule "Transform.ag"(line 42, column 19)@@ -1264,19 +1264,19 @@ -- use rule "Transform.ag"(line 145, column 31) _lhsOcollectedUniques = []- -- use rule "Transform.ag"(line 742, column 33)+ -- use rule "Transform.ag"(line 750, column 33) _lhsOderivings = Map.empty -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = _namesIerrors Seq.<> _attrsIerrors- -- use rule "Transform.ag"(line 894, column 37)+ -- use rule "Transform.ag"(line 902, column 37) _lhsOmoduleDecl = mzero -- use rule "Transform.ag"(line 598, column 34) _lhsOpragmas = id- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = Map.empty -- use rule "Transform.ag"(line 458, column 32)@@ -1365,10 +1365,10 @@ _setIcollectedNames :: (Set Identifier) _setIerrors :: (Seq Error) _setInontSet :: (Set NontermIdent)- -- "Transform.ag"(line 749, column 14)+ -- "Transform.ag"(line 757, column 14) _lhsOderivings = Map.fromList [(nt,Set.fromList classes_) | nt <- Set.toList _setInontSet]- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = Map.empty -- use rule "Transform.ag"(line 42, column 19)@@ -1398,22 +1398,22 @@ -- use rule "Transform.ag"(line 145, column 31) _lhsOcollectedUniques = []- -- use rule "Transform.ag"(line 717, column 34)+ -- use rule "Transform.ag"(line 725, column 34) _lhsOctxCollect = Map.empty -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = _setIerrors- -- use rule "Transform.ag"(line 894, column 37)+ -- use rule "Transform.ag"(line 902, column 37) _lhsOmoduleDecl = mzero- -- use rule "Transform.ag"(line 694, column 37)+ -- use rule "Transform.ag"(line 702, column 37) _lhsOparamsCollect = Map.empty -- use rule "Transform.ag"(line 598, column 34) _lhsOpragmas = id- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = Map.empty -- use rule "Transform.ag"(line 458, column 32)@@ -1478,10 +1478,10 @@ _lhsOwrappers :: (Set NontermIdent) _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier))- -- "Transform.ag"(line 898, column 7)+ -- "Transform.ag"(line 906, column 7) _lhsOmoduleDecl = Just (name_, exports_, imports_)- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = Map.empty -- use rule "Transform.ag"(line 42, column 19)@@ -1511,22 +1511,22 @@ -- use rule "Transform.ag"(line 145, column 31) _lhsOcollectedUniques = []- -- use rule "Transform.ag"(line 717, column 34)+ -- use rule "Transform.ag"(line 725, column 34) _lhsOctxCollect = Map.empty- -- use rule "Transform.ag"(line 742, column 33)+ -- use rule "Transform.ag"(line 750, column 33) _lhsOderivings = Map.empty -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = Seq.empty- -- use rule "Transform.ag"(line 694, column 37)+ -- use rule "Transform.ag"(line 702, column 37) _lhsOparamsCollect = Map.empty -- use rule "Transform.ag"(line 598, column 34) _lhsOpragmas = id- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = Map.empty -- use rule "Transform.ag"(line 458, column 32)@@ -1581,6 +1581,14 @@ -- "Transform.ag"(line 601, column 13) _lhsOpragmas = let mk n o = case getName n of+ "gencatas" -> o { folds = True }+ "nogencatas" -> o { folds = False }+ "gendatas" -> o { dataTypes = True }+ "nogendatas" -> o { dataTypes = False }+ "gensems" -> o { semfuns = True }+ "nogensems" -> o { semfuns = False }+ "gentypesigs" -> o { typeSigs = True }+ "nogentypesigs"-> o { typeSigs = False } "nocycle" -> o { withCycle = False } "cycle" -> o { withCycle = True } "nostrictdata" -> o { strictData = False }@@ -1612,7 +1620,7 @@ "nonewtypes" -> o { newtypes = False } _ -> o in \o -> foldr mk o names_- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = Map.empty -- use rule "Transform.ag"(line 42, column 19)@@ -1642,22 +1650,22 @@ -- use rule "Transform.ag"(line 145, column 31) _lhsOcollectedUniques = []- -- use rule "Transform.ag"(line 717, column 34)+ -- use rule "Transform.ag"(line 725, column 34) _lhsOctxCollect = Map.empty- -- use rule "Transform.ag"(line 742, column 33)+ -- use rule "Transform.ag"(line 750, column 33) _lhsOderivings = Map.empty -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = Seq.empty- -- use rule "Transform.ag"(line 894, column 37)+ -- use rule "Transform.ag"(line 902, column 37) _lhsOmoduleDecl = mzero- -- use rule "Transform.ag"(line 694, column 37)+ -- use rule "Transform.ag"(line 702, column 37) _lhsOparamsCollect = Map.empty- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = Map.empty -- use rule "Transform.ag"(line 458, column 32)@@ -1738,15 +1746,15 @@ -- "Transform.ag"(line 159, column 10) _altsOnts = _namesInontSet- -- "Transform.ag"(line 721, column 7)+ -- "Transform.ag"(line 729, column 7) _lhsOctxCollect = if null ctx_ then Map.empty else Map.fromList [(nt, ctx_) | nt <- Set.toList _namesInontSet]- -- "Transform.ag"(line 766, column 10)+ -- "Transform.ag"(line 774, column 10) _attrsOnts = _namesInontSet- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = _altsIattrOrderCollect -- use rule "Transform.ag"(line 42, column 19)@@ -1776,22 +1784,22 @@ -- use rule "Transform.ag"(line 145, column 31) _lhsOcollectedUniques = _altsIcollectedUniques- -- use rule "Transform.ag"(line 742, column 33)+ -- use rule "Transform.ag"(line 750, column 33) _lhsOderivings = Map.empty -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = _namesIerrors Seq.<> _attrsIerrors Seq.<> _altsIerrors- -- use rule "Transform.ag"(line 894, column 37)+ -- use rule "Transform.ag"(line 902, column 37) _lhsOmoduleDecl = mzero- -- use rule "Transform.ag"(line 694, column 37)+ -- use rule "Transform.ag"(line 702, column 37) _lhsOparamsCollect = Map.empty -- use rule "Transform.ag"(line 598, column 34) _lhsOpragmas = id- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = _altsIsemPragmasCollect -- use rule "Transform.ag"(line 458, column 32)@@ -1907,7 +1915,7 @@ -- "Transform.ag"(line 531, column 9) _lhsOerrors = _errs <> _setIerrors- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = Map.empty -- use rule "Transform.ag"(line 42, column 19)@@ -1934,22 +1942,22 @@ -- use rule "Transform.ag"(line 145, column 31) _lhsOcollectedUniques = []- -- use rule "Transform.ag"(line 717, column 34)+ -- use rule "Transform.ag"(line 725, column 34) _lhsOctxCollect = Map.empty- -- use rule "Transform.ag"(line 742, column 33)+ -- use rule "Transform.ag"(line 750, column 33) _lhsOderivings = Map.empty- -- use rule "Transform.ag"(line 894, column 37)+ -- use rule "Transform.ag"(line 902, column 37) _lhsOmoduleDecl = mzero- -- use rule "Transform.ag"(line 694, column 37)+ -- use rule "Transform.ag"(line 702, column 37) _lhsOparamsCollect = Map.empty -- use rule "Transform.ag"(line 598, column 34) _lhsOpragmas = id- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = Map.empty -- use rule "Transform.ag"(line 458, column 32)@@ -2027,7 +2035,7 @@ -- "Transform.ag"(line 177, column 10) _lhsOblocks = Map.singleton _blockInfo _blockValue- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = Map.empty -- use rule "Transform.ag"(line 88, column 48)@@ -2054,25 +2062,25 @@ -- use rule "Transform.ag"(line 145, column 31) _lhsOcollectedUniques = []- -- use rule "Transform.ag"(line 717, column 34)+ -- use rule "Transform.ag"(line 725, column 34) _lhsOctxCollect = Map.empty- -- use rule "Transform.ag"(line 742, column 33)+ -- use rule "Transform.ag"(line 750, column 33) _lhsOderivings = Map.empty -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = Seq.empty- -- use rule "Transform.ag"(line 894, column 37)+ -- use rule "Transform.ag"(line 902, column 37) _lhsOmoduleDecl = mzero- -- use rule "Transform.ag"(line 694, column 37)+ -- use rule "Transform.ag"(line 702, column 37) _lhsOparamsCollect = Map.empty -- use rule "Transform.ag"(line 598, column 34) _lhsOpragmas = id- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = Map.empty -- use rule "Transform.ag"(line 458, column 32)@@ -2176,17 +2184,17 @@ -- "Transform.ag"(line 507, column 11) _lhsOtypeSyns = [(name_,_argType)]- -- "Transform.ag"(line 704, column 7)+ -- "Transform.ag"(line 712, column 7) _lhsOparamsCollect = if null params_ then Map.empty else Map.singleton name_ params_- -- "Transform.ag"(line 727, column 7)+ -- "Transform.ag"(line 735, column 7) _lhsOctxCollect = if null ctx_ then Map.empty else Map.singleton name_ ctx_- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = Map.empty -- use rule "Transform.ag"(line 42, column 19)@@ -2210,19 +2218,19 @@ -- use rule "Transform.ag"(line 145, column 31) _lhsOcollectedUniques = []- -- use rule "Transform.ag"(line 742, column 33)+ -- use rule "Transform.ag"(line 750, column 33) _lhsOderivings = Map.empty -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = Seq.empty- -- use rule "Transform.ag"(line 894, column 37)+ -- use rule "Transform.ag"(line 902, column 37) _lhsOmoduleDecl = mzero -- use rule "Transform.ag"(line 598, column 34) _lhsOpragmas = id- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = Map.empty -- use rule "Transform.ag"(line 131, column 15)@@ -2280,7 +2288,7 @@ -- "Transform.ag"(line 592, column 13) _lhsOwrappers = _setInontSet- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = Map.empty -- use rule "Transform.ag"(line 42, column 19)@@ -2310,25 +2318,25 @@ -- use rule "Transform.ag"(line 145, column 31) _lhsOcollectedUniques = []- -- use rule "Transform.ag"(line 717, column 34)+ -- use rule "Transform.ag"(line 725, column 34) _lhsOctxCollect = Map.empty- -- use rule "Transform.ag"(line 742, column 33)+ -- use rule "Transform.ag"(line 750, column 33) _lhsOderivings = Map.empty -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = _setIerrors- -- use rule "Transform.ag"(line 894, column 37)+ -- use rule "Transform.ag"(line 902, column 37) _lhsOmoduleDecl = mzero- -- use rule "Transform.ag"(line 694, column 37)+ -- use rule "Transform.ag"(line 702, column 37) _lhsOparamsCollect = Map.empty -- use rule "Transform.ag"(line 598, column 34) _lhsOpragmas = id- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = Map.empty -- use rule "Transform.ag"(line 458, column 32)@@ -2505,7 +2513,7 @@ _tlItypeSyns :: TypeSyns _tlIuseMap :: (Map NontermIdent (Map Identifier (String,String,String))) _tlIwrappers :: (Set NontermIdent)- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = _hdIattrOrderCollect `orderMapUnion` _tlIattrOrderCollect -- use rule "Transform.ag"(line 42, column 19)@@ -2535,25 +2543,25 @@ -- use rule "Transform.ag"(line 145, column 31) _lhsOcollectedUniques = _hdIcollectedUniques ++ _tlIcollectedUniques- -- use rule "Transform.ag"(line 717, column 34)+ -- use rule "Transform.ag"(line 725, column 34) _lhsOctxCollect = _hdIctxCollect `mergeCtx` _tlIctxCollect- -- use rule "Transform.ag"(line 742, column 33)+ -- use rule "Transform.ag"(line 750, column 33) _lhsOderivings = _hdIderivings `mergeDerivings` _tlIderivings -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = _hdIerrors Seq.<> _tlIerrors- -- use rule "Transform.ag"(line 894, column 37)+ -- use rule "Transform.ag"(line 902, column 37) _lhsOmoduleDecl = _hdImoduleDecl `mplus` _tlImoduleDecl- -- use rule "Transform.ag"(line 694, column 37)+ -- use rule "Transform.ag"(line 702, column 37) _lhsOparamsCollect = _hdIparamsCollect `mergeParams` _tlIparamsCollect -- use rule "Transform.ag"(line 598, column 34) _lhsOpragmas = _hdIpragmas . _tlIpragmas- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = _hdIsemPragmasCollect `pragmaMapUnion` _tlIsemPragmasCollect -- use rule "Transform.ag"(line 458, column 32)@@ -2649,7 +2657,7 @@ _lhsOwrappers :: (Set NontermIdent) _lhsOattrDecls :: (Map NontermIdent (Attributes, Attributes)) _lhsOdefSets :: (Map Identifier (Set NontermIdent,Set Identifier))- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = Map.empty -- use rule "Transform.ag"(line 42, column 19)@@ -2679,25 +2687,25 @@ -- use rule "Transform.ag"(line 145, column 31) _lhsOcollectedUniques = []- -- use rule "Transform.ag"(line 717, column 34)+ -- use rule "Transform.ag"(line 725, column 34) _lhsOctxCollect = Map.empty- -- use rule "Transform.ag"(line 742, column 33)+ -- use rule "Transform.ag"(line 750, column 33) _lhsOderivings = Map.empty -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = Seq.empty- -- use rule "Transform.ag"(line 894, column 37)+ -- use rule "Transform.ag"(line 902, column 37) _lhsOmoduleDecl = mzero- -- use rule "Transform.ag"(line 694, column 37)+ -- use rule "Transform.ag"(line 702, column 37) _lhsOparamsCollect = Map.empty -- use rule "Transform.ag"(line 598, column 34) _lhsOpragmas = id- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = Map.empty -- use rule "Transform.ag"(line 458, column 32)@@ -3085,16 +3093,16 @@ _partsIdefinedAttrs :: ([AttrName]) _partsIdefinedInsts :: ([Identifier]) _partsIpatunder :: ([AttrName]->Patterns)- -- "Transform.ag"(line 870, column 11)+ -- "Transform.ag"(line 878, column 11) _lhsOdefinedAttrs = (field_, attr_) : _patIdefinedAttrs- -- "Transform.ag"(line 871, column 11)+ -- "Transform.ag"(line 879, column 11) _lhsOpatunder = \us -> if ((field_,attr_) `elem` us) then Underscore noPos else _copy- -- "Transform.ag"(line 872, column 11)+ -- "Transform.ag"(line 880, column 11) _lhsOdefinedInsts = (if field_ == _INST then [attr_] else []) ++ _patIdefinedInsts- -- "Transform.ag"(line 887, column 16)+ -- "Transform.ag"(line 895, column 16) _lhsOstpos = getPos field_ -- self rule@@ -3121,16 +3129,16 @@ _patsIdefinedAttrs :: ([AttrName]) _patsIdefinedInsts :: ([Identifier]) _patsIpatunder :: ([AttrName]->Patterns)- -- "Transform.ag"(line 874, column 12)+ -- "Transform.ag"(line 882, column 12) _lhsOpatunder = \us -> Constr name_ (_patsIpatunder us)- -- "Transform.ag"(line 885, column 16)+ -- "Transform.ag"(line 893, column 16) _lhsOstpos = getPos name_- -- use rule "Transform.ag"(line 865, column 42)+ -- use rule "Transform.ag"(line 873, column 42) _lhsOdefinedAttrs = _patsIdefinedAttrs- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = _patsIdefinedInsts -- self rule@@ -3155,13 +3163,13 @@ _patIdefinedInsts :: ([Identifier]) _patIpatunder :: ([AttrName]->Pattern) _patIstpos :: Pos- -- "Transform.ag"(line 876, column 17)+ -- "Transform.ag"(line 884, column 17) _lhsOpatunder = \us -> Irrefutable (_patIpatunder us)- -- use rule "Transform.ag"(line 865, column 42)+ -- use rule "Transform.ag"(line 873, column 42) _lhsOdefinedAttrs = _patIdefinedAttrs- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = _patIdefinedInsts -- self rule@@ -3189,16 +3197,16 @@ _patsIdefinedAttrs :: ([AttrName]) _patsIdefinedInsts :: ([Identifier]) _patsIpatunder :: ([AttrName]->Patterns)- -- "Transform.ag"(line 875, column 13)+ -- "Transform.ag"(line 883, column 13) _lhsOpatunder = \us -> Product pos_ (_patsIpatunder us)- -- "Transform.ag"(line 886, column 16)+ -- "Transform.ag"(line 894, column 16) _lhsOstpos = pos_- -- use rule "Transform.ag"(line 865, column 42)+ -- use rule "Transform.ag"(line 873, column 42) _lhsOdefinedAttrs = _patsIdefinedAttrs- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = _patsIdefinedInsts -- self rule@@ -3218,16 +3226,16 @@ _lhsOdefinedAttrs :: ([AttrName]) _lhsOdefinedInsts :: ([Identifier]) _lhsOcopy :: Pattern- -- "Transform.ag"(line 873, column 16)+ -- "Transform.ag"(line 881, column 16) _lhsOpatunder = \us -> _copy- -- "Transform.ag"(line 888, column 16)+ -- "Transform.ag"(line 896, column 16) _lhsOstpos = pos_- -- use rule "Transform.ag"(line 865, column 42)+ -- use rule "Transform.ag"(line 873, column 42) _lhsOdefinedAttrs = []- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = [] -- self rule@@ -3285,13 +3293,13 @@ _tlIdefinedAttrs :: ([AttrName]) _tlIdefinedInsts :: ([Identifier]) _tlIpatunder :: ([AttrName]->Patterns)- -- "Transform.ag"(line 880, column 10)+ -- "Transform.ag"(line 888, column 10) _lhsOpatunder = \us -> (_hdIpatunder us) : (_tlIpatunder us)- -- use rule "Transform.ag"(line 865, column 42)+ -- use rule "Transform.ag"(line 873, column 42) _lhsOdefinedAttrs = _hdIdefinedAttrs ++ _tlIdefinedAttrs- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = _hdIdefinedInsts ++ _tlIdefinedInsts -- self rule@@ -3311,13 +3319,13 @@ _lhsOdefinedAttrs :: ([AttrName]) _lhsOdefinedInsts :: ([Identifier]) _lhsOcopy :: Patterns- -- "Transform.ag"(line 879, column 9)+ -- "Transform.ag"(line 887, column 9) _lhsOpatunder = \us -> []- -- use rule "Transform.ag"(line 865, column 42)+ -- use rule "Transform.ag"(line 873, column 42) _lhsOdefinedAttrs = []- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = [] -- self rule@@ -3392,25 +3400,25 @@ _rulesIruleInfos :: ([RuleInfo]) _rulesIsigInfos :: ([SigInfo]) _rulesIuniqueInfos :: ([UniqueInfo])- -- "Transform.ag"(line 638, column 7)+ -- "Transform.ag"(line 646, column 7) _pragmaNames = Set.fromList _rulesIpragmaNamesCollect- -- "Transform.ag"(line 639, column 7)+ -- "Transform.ag"(line 647, column 7) _lhsOsemPragmasCollect = foldr pragmaMapUnion Map.empty [ pragmaMapSingle nt con _pragmaNames | (nt, conset, _) <- _coninfo , con <- Set.toList conset ]- -- "Transform.ag"(line 667, column 7)+ -- "Transform.ag"(line 675, column 7) _attrOrders = [ orderMapSingle nt con _rulesIorderDepsCollect | (nt, conset, _) <- _coninfo , con <- Set.toList conset ]- -- "Transform.ag"(line 673, column 7)+ -- "Transform.ag"(line 681, column 7) _lhsOattrOrderCollect = foldr orderMapUnion Map.empty _attrOrders- -- "Transform.ag"(line 816, column 12)+ -- "Transform.ag"(line 824, column 12) _coninfo = [ (nt, conset, conkeys) | nt <- Set.toList _lhsInts@@ -3418,34 +3426,34 @@ , let conkeys = Set.fromList (Map.keys conmap) , let conset = _constructorSetIconstructors conkeys ]- -- "Transform.ag"(line 823, column 12)+ -- "Transform.ag"(line 831, column 12) _lhsOerrors = Seq.fromList [ UndefAlt nt con | (nt, conset, conkeys) <- _coninfo , con <- Set.toList (Set.difference conset conkeys) ]- -- "Transform.ag"(line 828, column 12)+ -- "Transform.ag"(line 836, column 12) _lhsOcollectedRules = [ (nt,con,r) | (nt, conset, _) <- _coninfo , con <- Set.toList conset , r <- _rulesIruleInfos ]- -- "Transform.ag"(line 834, column 12)+ -- "Transform.ag"(line 842, column 12) _lhsOcollectedSigs = [ (nt,con,ts) | (nt, conset, _) <- _coninfo , con <- Set.toList conset , ts <- _rulesIsigInfos ]- -- "Transform.ag"(line 841, column 12)+ -- "Transform.ag"(line 849, column 12) _lhsOcollectedInsts = [ (nt,con,_rulesIdefinedInsts) | (nt, conset, _) <- _coninfo , con <- Set.toList conset ]- -- "Transform.ag"(line 847, column 12)+ -- "Transform.ag"(line 855, column 12) _lhsOcollectedUniques = [ (nt,con,_rulesIuniqueInfos) | (nt, conset, _) <- _coninfo@@ -3527,7 +3535,7 @@ _tlIcollectedUniques :: ([ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) _tlIerrors :: (Seq Error) _tlIsemPragmasCollect :: PragmaMap- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = _hdIattrOrderCollect `orderMapUnion` _tlIattrOrderCollect -- use rule "Transform.ag"(line 144, column 31)@@ -3545,7 +3553,7 @@ -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = _hdIerrors Seq.<> _tlIerrors- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = _hdIsemPragmasCollect `pragmaMapUnion` _tlIsemPragmasCollect -- copy rule (down)@@ -3583,7 +3591,7 @@ _lhsOcollectedUniques :: ([ (NontermIdent, ConstructorIdent, [UniqueInfo]) ]) _lhsOerrors :: (Seq Error) _lhsOsemPragmasCollect :: PragmaMap- -- use rule "Transform.ag"(line 662, column 55)+ -- use rule "Transform.ag"(line 670, column 55) _lhsOattrOrderCollect = Map.empty -- use rule "Transform.ag"(line 144, column 31)@@ -3601,7 +3609,7 @@ -- use rule "Transform.ag"(line 40, column 19) _lhsOerrors = Seq.empty- -- use rule "Transform.ag"(line 634, column 56)+ -- use rule "Transform.ag"(line 642, column 56) _lhsOsemPragmasCollect = Map.empty in ( _lhsOattrOrderCollect,_lhsOcollectedInsts,_lhsOcollectedRules,_lhsOcollectedSigs,_lhsOcollectedUniques,_lhsOerrors,_lhsOsemPragmasCollect))))@@ -3665,25 +3673,25 @@ _lhsOruleInfos :: ([RuleInfo]) _lhsOsigInfos :: ([SigInfo]) _lhsOuniqueInfos :: ([UniqueInfo])- -- "Transform.ag"(line 679, column 7)+ -- "Transform.ag"(line 687, column 7) _dependency = [ Dependency b a | b <- before_, a <- after_ ]- -- "Transform.ag"(line 680, column 7)+ -- "Transform.ag"(line 688, column 7) _lhsOorderDepsCollect = Set.fromList _dependency- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = []- -- use rule "Transform.ag"(line 644, column 46)+ -- use rule "Transform.ag"(line 652, column 46) _lhsOpragmaNamesCollect = []- -- use rule "Transform.ag"(line 809, column 39)+ -- use rule "Transform.ag"(line 817, column 39) _lhsOruleInfos = []- -- use rule "Transform.ag"(line 810, column 39)+ -- use rule "Transform.ag"(line 818, column 39) _lhsOsigInfos = []- -- use rule "Transform.ag"(line 811, column 39)+ -- use rule "Transform.ag"(line 819, column 39) _lhsOuniqueInfos = [] in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)))@@ -3703,22 +3711,22 @@ _patternIdefinedInsts :: ([Identifier]) _patternIpatunder :: ([AttrName]->Pattern) _patternIstpos :: Pos- -- "Transform.ag"(line 855, column 10)+ -- "Transform.ag"(line 863, column 10) _lhsOruleInfos = [ (_patternIpatunder, rhs_, _patternIdefinedAttrs, owrt_, show _patternIstpos) ]- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = _patternIdefinedInsts- -- use rule "Transform.ag"(line 675, column 44)+ -- use rule "Transform.ag"(line 683, column 44) _lhsOorderDepsCollect = Set.empty- -- use rule "Transform.ag"(line 644, column 46)+ -- use rule "Transform.ag"(line 652, column 46) _lhsOpragmaNamesCollect = []- -- use rule "Transform.ag"(line 810, column 39)+ -- use rule "Transform.ag"(line 818, column 39) _lhsOsigInfos = []- -- use rule "Transform.ag"(line 811, column 39)+ -- use rule "Transform.ag"(line 819, column 39) _lhsOuniqueInfos = [] ( _patternIcopy,_patternIdefinedAttrs,_patternIdefinedInsts,_patternIpatunder,_patternIstpos) =@@ -3733,22 +3741,22 @@ _lhsOruleInfos :: ([RuleInfo]) _lhsOsigInfos :: ([SigInfo]) _lhsOuniqueInfos :: ([UniqueInfo])- -- "Transform.ag"(line 648, column 7)+ -- "Transform.ag"(line 656, column 7) _lhsOpragmaNamesCollect = names_- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = []- -- use rule "Transform.ag"(line 675, column 44)+ -- use rule "Transform.ag"(line 683, column 44) _lhsOorderDepsCollect = Set.empty- -- use rule "Transform.ag"(line 809, column 39)+ -- use rule "Transform.ag"(line 817, column 39) _lhsOruleInfos = []- -- use rule "Transform.ag"(line 810, column 39)+ -- use rule "Transform.ag"(line 818, column 39) _lhsOsigInfos = []- -- use rule "Transform.ag"(line 811, column 39)+ -- use rule "Transform.ag"(line 819, column 39) _lhsOuniqueInfos = [] in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)))@@ -3762,22 +3770,22 @@ _lhsOpragmaNamesCollect :: ([Identifier]) _lhsOruleInfos :: ([RuleInfo]) _lhsOuniqueInfos :: ([UniqueInfo])- -- "Transform.ag"(line 858, column 14)+ -- "Transform.ag"(line 866, column 14) _lhsOsigInfos = [ (ident_, tp_) ]- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = []- -- use rule "Transform.ag"(line 675, column 44)+ -- use rule "Transform.ag"(line 683, column 44) _lhsOorderDepsCollect = Set.empty- -- use rule "Transform.ag"(line 644, column 46)+ -- use rule "Transform.ag"(line 652, column 46) _lhsOpragmaNamesCollect = []- -- use rule "Transform.ag"(line 809, column 39)+ -- use rule "Transform.ag"(line 817, column 39) _lhsOruleInfos = []- -- use rule "Transform.ag"(line 811, column 39)+ -- use rule "Transform.ag"(line 819, column 39) _lhsOuniqueInfos = [] in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)))@@ -3791,22 +3799,22 @@ _lhsOpragmaNamesCollect :: ([Identifier]) _lhsOruleInfos :: ([RuleInfo]) _lhsOsigInfos :: ([SigInfo])- -- "Transform.ag"(line 861, column 16)+ -- "Transform.ag"(line 869, column 16) _lhsOuniqueInfos = [ (ident_, ref_) ]- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = []- -- use rule "Transform.ag"(line 675, column 44)+ -- use rule "Transform.ag"(line 683, column 44) _lhsOorderDepsCollect = Set.empty- -- use rule "Transform.ag"(line 644, column 46)+ -- use rule "Transform.ag"(line 652, column 46) _lhsOpragmaNamesCollect = []- -- use rule "Transform.ag"(line 809, column 39)+ -- use rule "Transform.ag"(line 817, column 39) _lhsOruleInfos = []- -- use rule "Transform.ag"(line 810, column 39)+ -- use rule "Transform.ag"(line 818, column 39) _lhsOsigInfos = [] in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)))@@ -3861,22 +3869,22 @@ _tlIruleInfos :: ([RuleInfo]) _tlIsigInfos :: ([SigInfo]) _tlIuniqueInfos :: ([UniqueInfo])- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = _hdIdefinedInsts ++ _tlIdefinedInsts- -- use rule "Transform.ag"(line 675, column 44)+ -- use rule "Transform.ag"(line 683, column 44) _lhsOorderDepsCollect = _hdIorderDepsCollect `Set.union` _tlIorderDepsCollect- -- use rule "Transform.ag"(line 644, column 46)+ -- use rule "Transform.ag"(line 652, column 46) _lhsOpragmaNamesCollect = _hdIpragmaNamesCollect ++ _tlIpragmaNamesCollect- -- use rule "Transform.ag"(line 809, column 39)+ -- use rule "Transform.ag"(line 817, column 39) _lhsOruleInfos = _hdIruleInfos ++ _tlIruleInfos- -- use rule "Transform.ag"(line 810, column 39)+ -- use rule "Transform.ag"(line 818, column 39) _lhsOsigInfos = _hdIsigInfos ++ _tlIsigInfos- -- use rule "Transform.ag"(line 811, column 39)+ -- use rule "Transform.ag"(line 819, column 39) _lhsOuniqueInfos = _hdIuniqueInfos ++ _tlIuniqueInfos ( _hdIdefinedInsts,_hdIorderDepsCollect,_hdIpragmaNamesCollect,_hdIruleInfos,_hdIsigInfos,_hdIuniqueInfos) =@@ -3892,22 +3900,22 @@ _lhsOruleInfos :: ([RuleInfo]) _lhsOsigInfos :: ([SigInfo]) _lhsOuniqueInfos :: ([UniqueInfo])- -- use rule "Transform.ag"(line 864, column 55)+ -- use rule "Transform.ag"(line 872, column 55) _lhsOdefinedInsts = []- -- use rule "Transform.ag"(line 675, column 44)+ -- use rule "Transform.ag"(line 683, column 44) _lhsOorderDepsCollect = Set.empty- -- use rule "Transform.ag"(line 644, column 46)+ -- use rule "Transform.ag"(line 652, column 46) _lhsOpragmaNamesCollect = []- -- use rule "Transform.ag"(line 809, column 39)+ -- use rule "Transform.ag"(line 817, column 39) _lhsOruleInfos = []- -- use rule "Transform.ag"(line 810, column 39)+ -- use rule "Transform.ag"(line 818, column 39) _lhsOsigInfos = []- -- use rule "Transform.ag"(line 811, column 39)+ -- use rule "Transform.ag"(line 819, column 39) _lhsOuniqueInfos = [] in ( _lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)))
src/Ag.hs view
@@ -55,7 +55,7 @@ compile :: Options -> String -> String -> IO () compile flags input output- = do (output0,parseErrors) <- parseAG (searchPath flags) (inputFile input)+ = do (output0,parseErrors) <- parseAG flags (searchPath flags) (inputFile input) irrefutableMap <- readIrrefutableMap flags let output1 = Pass1.wrap_AG (Pass1.sem_AG output0 ) Pass1.Inh_AG {Pass1.options_Inh_AG = flags}@@ -268,7 +268,7 @@ reportDeps :: Options -> [String] -> IO () reportDeps flags files- = do results <- mapM (depsAG (searchPath flags)) files+ = do results <- mapM (depsAG flags (searchPath flags)) files let (fs, mesgs) = foldr combine ([],[]) results let errs = take (wmaxerrs flags) (map message2error mesgs) let ppErrs = PrErr.wrap_Errors (PrErr.sem_Errors errs) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags}
src/Options.hs view
@@ -53,6 +53,9 @@ , Option [] ["genattrlist"] (NoArg genAttrListOpt) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)" , Option [] ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set" , Option [] ["uniquedispenser"] (ReqArg uniqueDispenserOpt "name") "The Haskell function to call in the generated code"+ , Option [] ["lckeywords"] (NoArg lcKeywordsOpt) "Use lowercase keywords (sem, attr) instead of the uppercase ones (SEM, ATTR)"+ , Option [] ["doublecolons"] (NoArg doubleColonsOpt) "Use double colons for type signatures instead of single colons"+ , Option ['H'] ["haskellsyntax"] (NoArg haskellSyntaxOpt) "Use Haskell like syntax (equivalent to --lckeywords and --doublecolons --genlinepragmas)" ] allc = "dcfsprm"@@ -104,6 +107,8 @@ , genAttributeList :: Bool , forceIrrefutables :: Maybe String , uniqueDispenser :: String+ , lcKeywords :: Bool+ , doubleColons :: Bool } deriving Show noOptions = Options { moduleName = NoName , dataTypes = False@@ -152,6 +157,8 @@ , genAttributeList = False , forceIrrefutables = Nothing , uniqueDispenser = "nextUnique"+ , lcKeywords = False+ , doubleColons = False } @@ -200,6 +207,9 @@ genAttrListOpt opts = opts { genAttributeList = True } forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm } uniqueDispenserOpt nm opts = opts { uniqueDispenser = nm }+lcKeywordsOpt opts = opts { lcKeywords = True }+doubleColonsOpt opts = opts { doubleColons = True }+haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt outputOpt file opts = opts{outputFiles = file : outputFiles opts} searchPathOpt path opts = opts{searchPath = extract path ++ searchPath opts}
src/Parser.hs view
@@ -1,206 +1,209 @@-module Parser --(parseAG) -where -import Data.Maybe -import UU.Parsing -import UU.Parsing.Machine(RealParser(..),RealRecogn(..),anaDynE,mkPR) -import ConcreteSyntax -import CommonTypes -import Patterns -import UU.Pretty(text,PP_Doc,empty,(>-<)) -import TokenDef -import List (intersperse) -import Char -import Scanner (Input(..),scanLit,input) -import List -import Expression -import UU.Scanner.Token -import UU.Scanner.TokenParser -import UU.Scanner.GenToken -import UU.Scanner.GenTokenParser -import UU.Scanner.Position -import UU.Scanner.TokenShow() +module Parser+where+import Data.Maybe+import UU.Parsing+import UU.Parsing.Machine(RealParser(..),RealRecogn(..),anaDynE,mkPR)+import ConcreteSyntax+import CommonTypes+import Patterns+import UU.Pretty(text,PP_Doc,empty,(>-<))+import TokenDef+import List (intersperse)+import Char+import Scanner (Input(..),scanLit,input)+import List+import Expression+import UU.Scanner.Token+import UU.Scanner.TokenParser+import UU.Scanner.GenToken+import UU.Scanner.GenTokenParser+import UU.Scanner.Position+import UU.Scanner.TokenShow() import System.Directory-import HsTokenScanner - - -type AGParser = AnaParser Input Pair Token Pos - -pIdentifier, pIdentifierU :: AGParser Identifier -pIdentifierU = uncurry Ident <$> pConidPos -pIdentifier = uncurry Ident <$> pVaridPos - - -parseAG :: [FilePath] -> String -> IO (AG,[Message Token Pos]) -parseAG searchPath file - = do (es,_,_,mesg) <- parseFile searchPath file +import HsTokenScanner+import Options+++type AGParser = AnaParser Input Pair Token Pos++pIdentifier, pIdentifierU :: AGParser Identifier+pIdentifierU = uncurry Ident <$> pConidPos+pIdentifier = uncurry Ident <$> pVaridPos+++parseAG :: Options -> [FilePath] -> String -> IO (AG,[Message Token Pos])+parseAG opts searchPath file + = do (es,_,_,mesg) <- parseFile opts searchPath file return (AG es, mesg) -depsAG :: [FilePath] -> String -> IO ([String], [Message Token Pos])-depsAG searchPath file- = do (_,_,fs,mesgs) <- parseFile searchPath file- return (fs, mesgs) - -parseFile :: [FilePath] -> String -> IO ([Elem],[String],[String],[Message Token Pos ]) -parseFile searchPath file - = do txt <- readFile file - let litMode = ".lag" `isSuffixOf` file - (files,text) = if litMode then scanLit txt - else ([],txt) - tokens = input (initPos file) text - - steps = parse pElemsFiles tokens - stop (_,fs,_,_) = null fs +depsAG :: Options -> [FilePath] -> String -> IO ([String], [Message Token Pos])+depsAG opts searchPath file+ = do (_,_,fs,mesgs) <- parseFile opts searchPath file+ return (fs, mesgs)++parseFile :: Options -> [FilePath] -> String -> IO ([Elem],[String],[String],[Message Token Pos ])+parseFile opts searchPath file + = do txt <- readFile file+ let litMode = ".lag" `isSuffixOf` file+ (files,text) = if litMode then scanLit txt+ else ([],txt)+ tokens = input opts (initPos file) text++ steps = parse (pElemsFiles opts) tokens+ stop (_,fs,_,_) = null fs cont (es,fs,allfs,msg)- = do files <- mapM (resolveFile searchPath) fs - res <- mapM (parseFile searchPath) files + = do files <- mapM (resolveFile searchPath) fs+ res <- mapM (parseFile opts searchPath) files let (ess,fss,allfss, msgs) = unzip4 res- return (es ++ concat ess, concat fss, concat allfss ++ allfs, msg ++ concat msgs) + return (es ++ concat ess, concat fss, concat allfss ++ allfs, msg ++ concat msgs) let (Pair (es,fls) _ ,mesg) = evalStepsMessages steps- let allfs = files ++ fls - loopp stop cont (es,allfs,allfs,mesg) - -resolveFile :: [FilePath] -> FilePath -> IO FilePath -resolveFile path fname = search (path ++ ["."]) - where search (p:ps) = do dExists <- doesDirectoryExist p - if dExists - then do let filename = p++pathSeparator++fname - fExists <- doesFileExist filename - if fExists - then return filename - else search ps - else search ps - search [] = error ("File: " ++ show fname ++ " not found in search path: " ++ show (concat (intersperse ";" (path ++ ["."]))) ) - -pathSeparator = "/" - -evalStepsMessages :: (Eq s, Show s, Show p) => Steps a s p -> (a,[Message s p]) -evalStepsMessages steps = case steps of - OkVal v rest -> let (arg,ms) = evalStepsMessages rest - in (v arg,ms) - Ok rest -> evalStepsMessages rest - Cost _ rest -> evalStepsMessages rest - StRepair _ msg rest -> let (v,ms) = evalStepsMessages rest - in (v, msg:ms) - Best _ rest _ -> evalStepsMessages rest - NoMoreSteps v -> (v,[]) - -loopp ::(a->Bool) -> (a->IO a) -> a -> IO a -loopp pred cont x | pred x = return x - | otherwise = do x' <- cont x - loopp pred cont x' - -pElemsFiles :: AGParser ([Elem],[String]) -pElemsFiles = pFoldr (($),([],[])) pElem' - where pElem' = addElem <$> pElem - <|> pINCLUDE *> (addInc <$> pStringPos) - addElem e (es,fs) = (e:es, fs) - addInc (fn,_) (es,fs) = ( es,fn:fs) - -pCodescrapL = (\(ValToken _ str pos) -> (str, pos))<$> - parseScrapL <?> "a code block" - -parseScrapL :: AGParser Token -parseScrapL = let p acc = (\k (Input pos str next) -> - let (sc,rest) = case next of - Just (t@(ValToken TkTextln _ _), rs) -> (t,rs) - _ -> let (tok,p2,inp2) = codescrapL pos str - in (tok, input p2 inp2) - steps = k ( rest) - in (val (acc sc) steps) - ) - in anaDynE (mkPR (P (p ), R (p (const id)))) - -codescrapL p [] = (valueToken TkTextln "" p,p,[]) -codescrapL p (x:xs) | isSpace x = (updPos' x p) codescrapL xs - | otherwise = let refcol = column p - (p',sc,rest) = scrapL refcol p (x:xs) - in (valueToken TkTextln sc p,p',rest) - -scrapL ref p (x:xs) | isSpace x || column p >= ref = - let (p'',sc,inp) = updPos' x p (scrapL ref) xs - in (p'',x:sc,inp) - | otherwise =(p,[],x:xs) -scrapL ref p [] = (p,[],[]) - -pNontSet = set0 - where set0 = pChainr (Intersect <$ pIntersect) set1 - set1 = pChainl (Difference <$ pMinus) set2 - set2 = pChainr (pSucceed Union) set3 - set3 = pIdentifierU <**> opt (flip Path <$ pArrow <*> pIdentifierU) NamedSet - <|> All <$ pStar - <|> pParens set0 - -pNames :: AGParser [Identifier] -pNames = pList1 pIdentifier - -pAG :: AGParser AG -pAG = AG <$> pElems - -pElems :: AGParser Elems -pElems = pList_ng pElem - -pComplexType = List <$> pBracks pTypeEncapsulated + let allfs = files ++ fls+ loopp stop cont (es,allfs,allfs,mesg)++resolveFile :: [FilePath] -> FilePath -> IO FilePath+resolveFile path fname = search (path ++ ["."]) + where search (p:ps) = do dExists <- doesDirectoryExist p+ if dExists+ then do let filename = p++pathSeparator++fname+ fExists <- doesFileExist filename+ if fExists+ then return filename+ else search ps + else search ps+ search [] = error ("File: " ++ show fname ++ " not found in search path: " ++ show (concat (intersperse ";" (path ++ ["."]))) ) ++pathSeparator = "/"++evalStepsMessages :: (Eq s, Show s, Show p) => Steps a s p -> (a,[Message s p])+evalStepsMessages steps = case steps of+ OkVal v rest -> let (arg,ms) = evalStepsMessages rest+ in (v arg,ms)+ Ok rest -> evalStepsMessages rest+ Cost _ rest -> evalStepsMessages rest+ StRepair _ msg rest -> let (v,ms) = evalStepsMessages rest+ in (v, msg:ms)+ Best _ rest _ -> evalStepsMessages rest+ NoMoreSteps v -> (v,[])++loopp ::(a->Bool) -> (a->IO a) -> a -> IO a+loopp pred cont x | pred x = return x+ | otherwise = do x' <- cont x+ loopp pred cont x'+ +pElemsFiles :: Options -> AGParser ([Elem],[String])+pElemsFiles opts = pFoldr (($),([],[])) pElem'+ where pElem' = addElem <$> pElem opts+ <|> pINCLUDE *> (addInc <$> pStringPos)+ addElem e (es,fs) = (e:es, fs)+ addInc (fn,_) (es,fs) = ( es,fn:fs)++pCodescrapL opts = (\(ValToken _ str pos) -> (str, pos))<$>+ parseScrapL opts <?> "a code block"++parseScrapL :: Options -> AGParser Token+parseScrapL opts+ = let p acc = (\k (Input pos str next) ->+ let (sc,rest) = case next of+ Just (t@(ValToken TkTextln _ _), rs) -> (t,rs)+ _ -> let (tok,p2,inp2) = codescrapL pos str+ in (tok, input opts p2 inp2)+ steps = k ( rest)+ in (val (acc sc) steps)+ )+ in anaDynE (mkPR (P (p ), R (p (const id))))++codescrapL p [] = (valueToken TkTextln "" p,p,[])+codescrapL p (x:xs) | isSpace x = (updPos' x p) codescrapL xs+ | otherwise = let refcol = column p+ (p',sc,rest) = scrapL refcol p (x:xs)+ in (valueToken TkTextln sc p,p',rest)++scrapL ref p (x:xs) | isSpace x || column p >= ref =+ let (p'',sc,inp) = updPos' x p (scrapL ref) xs+ in (p'',x:sc,inp)+ | otherwise =(p,[],x:xs)+scrapL ref p [] = (p,[],[])++pNontSet = set0+ where set0 = pChainr (Intersect <$ pIntersect) set1+ set1 = pChainl (Difference <$ pMinus) set2+ set2 = pChainr (pSucceed Union) set3+ set3 = pIdentifierU <**> opt (flip Path <$ pArrow <*> pIdentifierU) NamedSet + <|> All <$ pStar+ <|> pParens set0++pNames :: AGParser [Identifier]+pNames = pList1 pIdentifier++-- pAG :: Options -> AGParser AG+-- pAG opts = AG <$> pElems opts++pElems :: Options -> AGParser Elems+pElems opts = pList_ng (pElem opts)++pComplexType opts = List <$> pBracks pTypeEncapsulated <|> Maybe <$ pMAYBE <*> pType <|> Either <$ pEITHER <*> pType <*> pType <|> Map <$ pMAP <*> pTypePrimitive <*> pType- <|> IntMap <$ pINTMAP <*> pType - <|> tuple <$> pParens (pListSep pComma field) - where field = (,) <$> ((Just <$> pIdentifier <* pColon) `opt` Nothing) <*> pTypeEncapsulated - tuple xs = Tuple [(fromMaybe (Ident ("x"++show n) noPos) f, t) - | (n,(f,t)) <- zip [1..] xs - ] -pElem :: AGParser Elem -pElem = Data <$> pDATA- <*> pOptClassContext + <|> IntMap <$ pINTMAP <*> pType+ <|> tuple <$> pParens (pListSep pComma field)+ where field = (,) <$> ((Just <$> pIdentifier <* pTypeColon opts) `opt` Nothing) <*> pTypeEncapsulated+ tuple xs = Tuple [(fromMaybe (Ident ("x"++show n) noPos) f, t) + | (n,(f,t)) <- zip [1..] xs+ ]+pElem :: Options -> AGParser Elem+pElem opts+ = Data <$> pDATA+ <*> pOptClassContext <*> pNontSet- <*> pList pIdentifier - <*> pOptAttrs - <*> pAlts - <*> pSucceed False + <*> pList pIdentifier+ <*> pOptAttrs opts+ <*> pAlts opts+ <*> pSucceed False <|> Attr <$> pATTR- <*> pOptClassContext - <*> pNontSet - <*> pAttrs + <*> pOptClassContext+ <*> pNontSet+ <*> pAttrs opts <|> Type <$> pTYPE- <*> pOptClassContext + <*> pOptClassContext <*> pIdentifierU- <*> pList pIdentifier - <* pEquals - <*> pComplexType + <*> pList pIdentifier+ <* pEquals+ <*> pComplexType opts <|> Sem <$> pSEM <*> pOptClassContext- <*> pNontSet - <*> pOptAttrs - <*> pSemAlts - <|> Set <$> pSET - <*> pIdentifierU - <* pEquals - <*> pNontSet - <|> Deriving - <$> pDERIVING - <*> pNontSet - <* pColon - <*> pListSep pComma pIdentifierU - <|> Wrapper - <$> pWRAPPER - <*> pNontSet - <|> Pragma - <$> pPRAGMA + <*> pNontSet+ <*> pOptAttrs opts+ <*> pSemAlts opts+ <|> Set <$> pSET+ <*> pIdentifierU+ <* pEquals+ <*> pNontSet+ <|> Deriving+ <$> pDERIVING+ <*> pNontSet+ <* pColon+ <*> pListSep pComma pIdentifierU+ <|> Wrapper+ <$> pWRAPPER+ <*> pNontSet+ <|> Pragma+ <$> pPRAGMA <*> pNames <|> Module <$> pMODULE <*> pCodescrap' <*> pCodescrap' <*> pCodescrap'- <|> codeBlock <$> (pIdentifier <|> pSucceed (Ident "" noPos)) <*> ((Just <$ pATTACH <*> pIdentifierU) <|> pSucceed Nothing) <*> pCodeBlock <?> "a statement" + <|> codeBlock <$> (pIdentifier <|> pSucceed (Ident "" noPos)) <*> ((Just <$ pATTACH <*> pIdentifierU) <|> pSucceed Nothing) <*> pCodeBlock <?> "a statement" where codeBlock nm mbNt (txt,pos) = Txt pos nm mbNt (lines txt) --- Insertion is expensive for pCodeBlock in order to prevent infinite inserts. -pCodeBlock :: AGParser (String,Pos) -pCodeBlock = pCostValToken 90 TkTextln "" <?> "a code block" - - +-- Insertion is expensive for pCodeBlock in order to prevent infinite inserts.+pCodeBlock :: AGParser (String,Pos)+pCodeBlock = pCostValToken 90 TkTextln "" <?> "a code block"++ pOptClassContext :: AGParser ClassContext pOptClassContext = pClassContext <* pDoubleArrow@@ -210,15 +213,30 @@ pClassContext = pListSep pComma ((,) <$> pIdentifierU <*> pList pTypeHaskellAnyAsString) -pAttrs :: AGParser Attrs -pAttrs = Attrs <$> pOBrackPos <*> (concat <$> pList pInhAttrNames <?> "inherited attribute declarations") - <* pBar <*> (concat <$> pList pAttrNames <?> "chained attribute declarations" ) - <* pBar <*> (concat <$> pList pAttrNames <?> "synthesised attribute declarations" ) - <* pCBrack - -pOptAttrs :: AGParser Attrs -pOptAttrs = pAttrs `opt` Attrs noPos [] [] []+pAttrs :: Options -> AGParser Attrs+pAttrs opts+ = Attrs <$> pOBrackPos <*> (concat <$> pList (pInhAttrNames opts) <?> "inherited attribute declarations")+ <* pBar <*> (concat <$> pList (pAttrNames opts) <?> "chained attribute declarations" )+ <* pBar <*> (concat <$> pList (pAttrNames opts) <?> "synthesised attribute declarations" )+ <* pCBrack+ <|> (\ds -> Attrs (fst $ head ds) [n | (_,Left nms) <- ds, n <- nms] [] [n | (_,Right nms) <- ds, n <- nms]) <$> pList1 (pSingleAttrDefs opts) +pSingleAttrDefs :: Options -> AGParser (Pos, Either AttrNames AttrNames)+pSingleAttrDefs opts+ = (\p is -> (p, Left is)) <$> pINH <*> pList1Sep pComma (pSingleInhAttrDef opts)+ <|> (\p is -> (p, Right is)) <$> pSYN <*> pList1Sep pComma (pSingleSynAttrDef opts)++pSingleInhAttrDef :: Options -> AGParser (Identifier,Type,(String,String,String))+pSingleInhAttrDef opts+ = (\v tp -> (v,tp,("","",""))) <$> pIdentifier <* pTypeColon opts <*> pType <?> "inh attribute declaration"++pSingleSynAttrDef :: Options -> AGParser (Identifier,Type,(String,String,String))+pSingleSynAttrDef opts+ = (\v u tp -> (v,tp,u)) <$> pIdentifier <*> pUse <* pTypeColon opts <*> pType <?> "syn attribute declaration"++pOptAttrs :: Options -> AGParser Attrs+pOptAttrs opts = pAttrs opts `opt` Attrs noPos [] [] []+ pTypeNt :: AGParser Type pTypeNt = ((\nt -> NT nt []) <$> pIdentifierU <?> "nonterminal name (no brackets)")@@ -240,180 +258,194 @@ pTypePrimitive :: AGParser Type pTypePrimitive- = Haskell <$> pCodescrap' <?> "a type" - -pType :: AGParser Type -pType = pTypeNt - <|> pTypePrimitive - - -pInhAttrNames :: AGParser AttrNames -pInhAttrNames = (\vs tp -> map (\v -> (v,tp,("","",""))) vs) - <$> pIdentifiers <* pColon <*> pType <?> "attribute declarations" - -pIdentifiers :: AGParser [Identifier] -pIdentifiers = pList1Sep pComma pIdentifier <?> "lowercase identifiers" - - -pAttrNames :: AGParser AttrNames -pAttrNames = (\vs use tp -> map (\v -> (v,tp,use)) vs) - <$> pIdentifiers <*> pUse <* pColon <*> pType <?> "attribute declarations" - -pUse :: AGParser (String,String,String) -pUse = ( (\u x y->(x,y,show u)) <$> pUSE <*> pCodescrap' <*> pCodescrap')` opt` ("","","") <?> "USE declaration" - -pAlt :: AGParser Alt -pAlt = Alt <$> pBar <*> pSimpleConstructorSet <*> pFields <?> "a datatype alternative" - -pAlts :: AGParser Alts -pAlts = pList_ng pAlt <?> "datatype alternatives" - -pFields :: AGParser Fields -pFields = concat <$> pList_ng pField <?> "fields" - -pField :: AGParser Fields -pField = (\nms tp -> map (flip (,) tp) nms) - <$> pIdentifiers <* pColon <*> pType - <|> (\s -> [(Ident (mklower (getName s)) (getPos s) ,NT s [])]) <$> pIdentifierU - -mklower :: String -> String -mklower (x:xs) = toLower x : xs -mklower [] = [] - -pSemAlt :: AGParser SemAlt -pSemAlt = SemAlt - <$> pBar <*> pConstructorSet <*> pSemDefs <?> "SEM alternative" - -pSimpleConstructorSet :: AGParser ConstructorSet -pSimpleConstructorSet = CName <$> pIdentifierU - <|> CAll <$ pStar - <|> pParens pConstructorSet - -pConstructorSet :: AGParser ConstructorSet -pConstructorSet = pChainl (CDifference <$ pMinus) term2 - where term2 = pChainr (pSucceed CUnion) term1 - term1 = CName <$> pIdentifierU - <|> CAll <$ pStar - - -pSemAlts :: AGParser SemAlts -pSemAlts = pList pSemAlt <?> "SEM alternatives" - + = Haskell <$> pCodescrap' <?> "a type"++pType :: AGParser Type+pType = pTypeNt+ <|> pTypePrimitive+++pInhAttrNames :: Options -> AGParser AttrNames+pInhAttrNames opts+ = (\vs tp -> map (\v -> (v,tp,("","",""))) vs)+ <$> pIdentifiers <* pTypeColon opts <*> pType <?> "attribute declarations"++pIdentifiers :: AGParser [Identifier]+pIdentifiers = pList1Sep pComma pIdentifier <?> "lowercase identifiers"+++pAttrNames :: Options -> AGParser AttrNames+pAttrNames opts + = (\vs use tp -> map (\v -> (v,tp,use)) vs)+ <$> pIdentifiers <*> pUse <* pTypeColon opts <*> pType <?> "attribute declarations"++pUse :: AGParser (String,String,String)+pUse = ( (\u x y->(x,y,show u)) <$> pUSE <*> pCodescrap' <*> pCodescrap')` opt` ("","","") <?> "USE declaration"++pAlt :: Options -> AGParser Alt+pAlt opts = Alt <$> pBar <*> pSimpleConstructorSet <*> pFields opts <?> "a datatype alternative"++pAlts :: Options -> AGParser Alts+pAlts opts = pList_ng (pAlt opts) <?> "datatype alternatives"++pFields :: Options -> AGParser Fields+pFields opts = concat <$> pList_ng (pField opts) <?> "fields"++pField :: Options -> AGParser Fields+pField opts+ = (\nms tp -> map (flip (,) tp) nms)+ <$> pIdentifiers <* pTypeColon opts <*> pType+ <|> (\s -> [(Ident (mklower (getName s)) (getPos s) ,NT s [])]) <$> pIdentifierU++mklower :: String -> String+mklower (x:xs) = toLower x : xs+mklower [] = []++pSemAlt :: Options -> AGParser SemAlt+pSemAlt opts = SemAlt <$> pBar <*> pConstructorSet <*> pSemDefs opts <?> "SEM alternative"++pSimpleConstructorSet :: AGParser ConstructorSet+pSimpleConstructorSet = CName <$> pIdentifierU+ <|> CAll <$ pStar+ <|> pParens pConstructorSet++pConstructorSet :: AGParser ConstructorSet+pConstructorSet = pChainl (CDifference <$ pMinus) term2+ where term2 = pChainr (pSucceed CUnion) term1+ term1 = CName <$> pIdentifierU+ <|> CAll <$ pStar+ ++pSemAlts :: Options -> AGParser SemAlts+pSemAlts opts = pList (pSemAlt opts) <?> "SEM alternatives"+ pFieldIdentifier :: AGParser Identifier-pFieldIdentifier = pIdentifier - <|> Ident "lhs" <$> pLHS +pFieldIdentifier = pIdentifier+ <|> Ident "lhs" <$> pLHS <|> Ident "loc" <$> pLOC- <|> Ident "inst" <$> pINST - -pSemDef :: AGParser [SemDef] -pSemDef = (\x fs -> map ($ x) fs)<$> pFieldIdentifier <*> pList1 pAttrDef - <|> pLOC *> pList1 pLocDecl- <|> pINST *> pList1 pInstDecl+ <|> Ident "inst" <$> pINST++pSemDef :: Options -> AGParser [SemDef]+pSemDef opts+ = (\x fs -> map ($ x) fs)<$> pFieldIdentifier <*> pList1 (pAttrDef opts)+ <|> pLOC *> pList1 (pLocDecl opts)+ <|> pINST *> pList1 (pInstDecl opts) <|> pSEMPRAGMA *> pList1 (SemPragma <$> pNames) <|> (\a b -> [AttrOrderBefore a [b]]) <$> pList1 pAttr <* pSmaller <*> pAttr- <|> (\pat owrt exp -> [Def (pat ()) exp owrt]) <$> pPattern (const <$> pAttr) <*> pAssign <*> pExpr - -pAttr = (,) <$> pFieldIdentifier <* pDot <*> pIdentifier - -pAttrDef :: AGParser (Identifier -> SemDef) -pAttrDef = (\pat owrt exp fld -> Def (pat fld) exp owrt) - <$ pDot <*> pattern <*> pAssign <*> pExpr - where pattern = pPattern pVar + <|> (\pat owrt exp -> [Def (pat ()) exp owrt]) <$> pPattern (const <$> pAttr) <*> pAssign <*> pExpr opts+ +pAttr = (,) <$> pFieldIdentifier <* pDot <*> pIdentifier+ +pAttrDef :: Options -> AGParser (Identifier -> SemDef)+pAttrDef opts+ = (\pat owrt exp fld -> Def (pat fld) exp owrt)+ <$ pDot <*> pattern <*> pAssign <*> pExpr opts+ where pattern = pPattern pVar <|> (\ir a fld -> ir $ Alias fld a (Underscore noPos) []) <$> ((Irrefutable <$ pTilde) `opt` id) <*> pIdentifier- - -nl2sp :: Char -> Char -nl2sp '\n' = ' ' -nl2sp '\r' = ' ' -nl2sp x = x - -pLocDecl :: AGParser SemDef -pLocDecl = pDot <**> (pIdentifier <**> (pColon <**> ( (\tp _ ident _ -> TypeDef ident tp) <$> pLocType- <|> (\ref _ ident _ -> UniqueDef ident ref) <$ pUNIQUEREF <*> pIdentifier ))) -pLocType = (Haskell . getName) <$> pIdentifierU ++nl2sp :: Char -> Char+nl2sp '\n' = ' '+nl2sp '\r' = ' '+nl2sp x = x++pLocDecl :: Options -> AGParser SemDef+pLocDecl opts = pDot <**> (pIdentifier <**> (pTypeColon opts <**> ( (\tp _ ident _ -> TypeDef ident tp) <$> pLocType+ <|> (\ref _ ident _ -> UniqueDef ident ref) <$ pUNIQUEREF <*> pIdentifier )))++pLocType = (Haskell . getName) <$> pIdentifierU <|> Haskell <$> pCodescrap' <?> "a type" -pInstDecl :: AGParser SemDef-pInstDecl = (\ident tp -> TypeDef ident tp)- <$ pDot <*> pIdentifier <* pColon <*> pTypeNt - -pSemDefs :: AGParser SemDefs -pSemDefs = concat <$> pList_ng pSemDef <?> "attribute rules" - -pVar :: AGParser (Identifier -> (Identifier, Identifier)) -pVar = (\att fld -> (fld,att)) <$> pIdentifier - - -pExpr :: AGParser Expression -pExpr = (\(str,pos) -> Expression pos (lexTokens pos str)) <$> pCodescrapL <?> "an expression" - -pAssign :: AGParser Bool -pAssign = False <$ pReserved "=" - <|> True <$ pReserved ":=" - -pAttrDefs :: AGParser (Identifier -> [SemDef]) -pAttrDefs = (\fs field -> map ($ field) fs) <$> pList1 pAttrDef <?> "attribute definitions" - -pPattern :: AGParser (a -> (Identifier,Identifier)) -> AGParser (a -> Pattern) -pPattern pvar = pPattern2 where - pPattern0 = (\i pats a -> Constr i (map ($ a) pats)) - <$> pIdentifierU <*> pList pPattern1 - <|> pPattern1 <?> "a pattern" +pInstDecl :: Options -> AGParser SemDef+pInstDecl opts = (\ident tp -> TypeDef ident tp)+ <$ pDot <*> pIdentifier <* pTypeColon opts <*> pTypeNt++pSemDefs :: Options -> AGParser SemDefs+pSemDefs opts = concat <$> pList_ng (pSemDef opts) <?> "attribute rules"++pVar :: AGParser (Identifier -> (Identifier, Identifier))+pVar = (\att fld -> (fld,att)) <$> pIdentifier++ +pExpr :: Options -> AGParser Expression+pExpr opts = (\(str,pos) -> Expression pos (lexTokens pos str)) <$> pCodescrapL opts <?> "an expression"++pAssign :: AGParser Bool+pAssign = False <$ pReserved "="+ <|> True <$ pReserved ":="+ +-- pAttrDefs :: Options -> AGParser (Identifier -> [SemDef])+-- pAttrDefs opts = (\fs field -> map ($ field) fs) <$> pList1 (pAttrDef opts) <?> "attribute definitions"++pPattern :: AGParser (a -> (Identifier,Identifier)) -> AGParser (a -> Pattern)+pPattern pvar = pPattern2 where+ pPattern0 = (\i pats a -> Constr i (map ($ a) pats))+ <$> pIdentifierU <*> pList pPattern1+ <|> pPattern1 <?> "a pattern" pPattern1 = pvariable- <|> pPattern2 - pvariable = (\ir var pat a -> case var a of (fld,att) -> ir $ Alias fld att (pat a) []) - <$> ((Irrefutable <$ pTilde) `opt` id) <*> pvar <*> ((pAt *> pPattern1) `opt` const (Underscore noPos)) - pPattern2 = (mkTuple <$> pOParenPos <*> pListSep pComma pPattern0 <* pCParen ) + <|> pPattern2+ pvariable = (\ir var pat a -> case var a of (fld,att) -> ir $ Alias fld att (pat a) []) + <$> ((Irrefutable <$ pTilde) `opt` id) <*> pvar <*> ((pAt *> pPattern1) `opt` const (Underscore noPos)) + pPattern2 = (mkTuple <$> pOParenPos <*> pListSep pComma pPattern0 <* pCParen ) <|> (const . Underscore) <$> pUScore <?> "a pattern"- where mkTuple _ [x] a = x a - mkTuple p xs a = Product p (map ($ a) xs) - -pCostSym' c t = pCostSym c t t - -pCodescrap' :: AGParser String -pCodescrap' = fst <$> pCodescrap - -pCodescrap :: AGParser (String,Pos) -pCodescrap = pCodeBlock - -pSEM, pATTR, pDATA, pUSE, pLOC,pINCLUDE, pTYPE, pEquals, pColonEquals, pTilde, - pBar, pColon, pLHS,pINST,pSET,pDERIVING,pMinus,pIntersect,pDoubleArrow,pArrow, + where mkTuple _ [x] a = x a+ mkTuple p xs a = Product p (map ($ a) xs)++pCostSym' c t = pCostSym c t t++pCodescrap' :: AGParser String+pCodescrap' = fst <$> pCodescrap++pCodescrap :: AGParser (String,Pos)+pCodescrap = pCodeBlock++pTypeColon :: Options -> AGParser Pos+pTypeColon opts+ = if doubleColons opts+ then pDoubleColon+ else pColon+++pSEM, pATTR, pDATA, pUSE, pLOC,pINCLUDE, pTYPE, pEquals, pColonEquals, pTilde,+ pBar, pColon, pLHS,pINST,pSET,pDERIVING,pMinus,pIntersect,pDoubleArrow,pArrow, pDot, pUScore, pEXT,pAt,pStar, pSmaller, pWRAPPER, pPRAGMA, pMAYBE, pEITHER, pMAP, pINTMAP,- pMODULE, pATTACH, pUNIQUEREF - :: AGParser Pos -pSET = pCostReserved 90 "SET" <?> "SET" -pDERIVING = pCostReserved 90 "DERIVING"<?> "DERIVING" -pWRAPPER = pCostReserved 90 "WRAPPER" <?> "WRAPPER" + pMODULE, pATTACH, pUNIQUEREF, pINH, pSYN+ :: AGParser Pos+pSET = pCostReserved 90 "SET" <?> "SET"+pDERIVING = pCostReserved 90 "DERIVING"<?> "DERIVING"+pWRAPPER = pCostReserved 90 "WRAPPER" <?> "WRAPPER" pPRAGMA = pCostReserved 90 "PRAGMA" <?> "PRAGMA" pSEMPRAGMA = pCostReserved 90 "SEMPRAGMA" <?> "SEMPRAGMA"-pATTACH = pCostReserved 90 "ATTACH" <?> "ATTACH" -pDATA = pCostReserved 90 "DATA" <?> "DATA" -pEXT = pCostReserved 90 "EXT" <?> "EXT" -pATTR = pCostReserved 90 "ATTR" <?> "ATTR" -pSEM = pCostReserved 90 "SEM" <?> "SEM" -pINCLUDE = pCostReserved 90 "INCLUDE" <?> "INCLUDE" -pTYPE = pCostReserved 90 "TYPE" <?> "TYPE" +pATTACH = pCostReserved 90 "ATTACH" <?> "ATTACH"+pDATA = pCostReserved 90 "DATA" <?> "DATA"+pEXT = pCostReserved 90 "EXT" <?> "EXT"+pATTR = pCostReserved 90 "ATTR" <?> "ATTR"+pSEM = pCostReserved 90 "SEM" <?> "SEM"+pINCLUDE = pCostReserved 90 "INCLUDE" <?> "INCLUDE"+pTYPE = pCostReserved 90 "TYPE" <?> "TYPE"+pINH = pCostReserved 90 "INH" <?> "INH"+pSYN = pCostReserved 90 "SYN" <?> "SYN" pMAYBE = pCostReserved 5 "MAYBE" <?> "MAYBE" pEITHER = pCostReserved 5 "EITHER" <?> "EITHER" pMAP = pCostReserved 5 "MAP" <?> "MAP"-pINTMAP = pCostReserved 5 "INTMAP" <?> "INTMAP" -pUSE = pCostReserved 5 "USE" <?> "USE" -pLOC = pCostReserved 5 "loc" <?> "loc" +pINTMAP = pCostReserved 5 "INTMAP" <?> "INTMAP"+pUSE = pCostReserved 5 "USE" <?> "USE"+pLOC = pCostReserved 5 "loc" <?> "loc" pLHS = pCostReserved 5 "lhs" <?> "loc"-pINST = pCostReserved 5 "inst" <?> "inst" -pAt = pCostReserved 5 "@" <?> "@" -pDot = pCostReserved 5 "." <?> "." -pUScore = pCostReserved 5 "_" <?> "_" -pColon = pCostReserved 5 ":" <?> ":" -pEquals = pCostReserved 5 "=" <?> "=" +pINST = pCostReserved 5 "inst" <?> "inst"+pAt = pCostReserved 5 "@" <?> "@"+pDot = pCostReserved 5 "." <?> "."+pUScore = pCostReserved 5 "_" <?> "_"+pColon = pCostReserved 5 ":" <?> ":"+pDoubleColon = pCostReserved 5 "::" <?> "::"+pEquals = pCostReserved 5 "=" <?> "=" pColonEquals = pCostReserved 5 ":=" <?> ":="-pTilde = pCostReserved 5 "~" <?> "~" -pBar = pCostReserved 5 "|" <?> "|" -pIntersect = pCostReserved 5 "/\\" <?> "/\\" +pTilde = pCostReserved 5 "~" <?> "~"+pBar = pCostReserved 5 "|" <?> "|"+pIntersect = pCostReserved 5 "/\\" <?> "/\\" pMinus = pCostReserved 5 "-" <?> "-"-pDoubleArrow = pCostReserved 5 "=>" <?> "=>" -pArrow = pCostReserved 5 "->" <?> "->" +pDoubleArrow = pCostReserved 5 "=>" <?> "=>"+pArrow = pCostReserved 5 "->" <?> "->" pStar = pCostReserved 5 "*" <?> "*" pSmaller = pCostReserved 5 "<" <?> "<" pMODULE = pCostReserved 5 "MODULE" <?> "MODULE"
src/Scanner.hs view
@@ -1,4 +1,7 @@+{-# OPTIONS -fglasgow-exts #-}+ module Scanner where +import GHC.Prim import TokenDef import UU.Scanner.Position import UU.Scanner.Token @@ -6,7 +9,8 @@ import Maybe import List import Char -import UU.Scanner.GenToken +import UU.Scanner.GenToken+import Options data Input = Input !Pos String (Maybe (Token, Input)) @@ -18,103 +22,116 @@ splitState (Input _ _ next) = case next of Nothing -> error "splitState on empty input" - Just (s, rest) -> ( s, rest) + Just (s, rest) -> (# s, rest #) getPosition (Input pos _ next) = case next of Just (s,_) -> position s Nothing -> pos -- end of file -input :: Pos -> String -> Input -input pos inp = Input pos +input :: Options -> Pos -> String -> Input +input opts pos inp = Input pos inp - (case scan pos inp of + (case scan opts pos inp of Nothing -> Nothing - Just (s,p,r) -> Just (s, input p r) + Just (s,p,r) -> Just (s, input opts p r) ) type Lexer s = Pos -> String -> Maybe (s,Pos,String) - -scan :: Lexer Token -scan p [] = Nothing -scan p ('-':'-':xs) = let (com,rest) = span (/= '\n') xs - in advc' (2+length com) p scan rest -scan p ('{':'-':xs) = advc' 2 p (ncomment scan) xs -scan p ('{' :xs) = advc' 1 p codescrap xs -scan p ('\CR':xs) = case xs of - '\LF':ys -> newl' p scanBeginOfLine ys --ms newline - _ -> newl' p scanBeginOfLine xs --mac newline -scan p ('\LF':xs) = newl' p scanBeginOfLine xs --unix newline -scan p (x:xs) | isSpace x = updPos' x p scan xs -scan p xs = Just (scan' xs) - where scan' ('.' :rs) = (reserved "." p, advc 1 p, rs) - scan' ('@' :rs) = (reserved "@" p, advc 1 p, rs) - scan' (',' :rs) = (reserved "," p, advc 1 p, rs) - scan' ('_' :rs) = (reserved "_" p, advc 1 p, rs)- scan' ('~' :rs) = (reserved "~" p, advc 1 p, rs)- scan' ('<' :rs) = (reserved "<" p, advc 1 p, rs) - scan' ('[' :rs) = (reserved "[" p, advc 1 p, rs) - scan' (']' :rs) = (reserved "]" p, advc 1 p, rs) - scan' ('(' :rs) = (reserved "(" p, advc 1 p, rs) - scan' (')' :rs) = (reserved ")" p, advc 1 p, rs) --- scan' ('{' :rs) = (OBrace p, advc 1 p, rs) --- scan' ('}' :rs) = (CBrace p, advc 1 p, rs) - - scan' ('\"' :rs) = let isOk c = c /= '"' && c /= '\n' - (str,rest) = span isOk rs - in if null rest || head rest /= '"' - then (errToken "unterminated string literal" p - , advc (1+length str) p,rest) - else (valueToken TkString str p, advc (2+length str) p, tail rest) - - scan' ('=' : '>' : rs) = (reserved "=>" p, advc 2 p, rs)- scan' ('=' :rs) = (reserved "=" p, advc 1 p, rs) - scan' (':':'=':rs) = (reserved ":=" p, advc 2 p, rs) - - scan' (':' :rs) = (reserved ":" p, advc 1 p, rs) - scan' ('|' :rs) = (reserved "|" p, advc 1 p, rs) - - scan' ('/':'\\':rs) = (reserved "/\\" p, advc 2 p, rs) - scan' ('-':'>' :rs) = (reserved "->" p, advc 2 p, rs) - scan' ('-' :rs) = (reserved "-" p, advc 1 p, rs) - scan' ('*' :rs) = (reserved "*" p, advc 1 p, rs) - - scan' (x:rs) | isLower x = let (var,rest) = ident rs - str = (x:var) - tok | str `elem` keywords = reserved str - | otherwise = valueToken TkVarid str - in (tok p, advc (length var+1) p, rest) - | isUpper x = let (var,rest) = ident rs - str = (x:var) - tok | str `elem` keywords = reserved str - | otherwise = valueToken TkConid str - in (tok p, advc (length var+1) p,rest) - | otherwise = (errToken ("unexpected character " ++ show x) p, advc 1 p, rs) -scanBeginOfLine :: Lexer Token-scanBeginOfLine p ('{' : '-' : ' ' : 'L' : 'I' : 'N' : 'E' : ' ' : xs)- | isOkBegin rs && isOkEnd rs'- = scan (advc (8 + length r + 2 + length s + 4) p') (drop 4 rs')- | otherwise- = Just (errToken ("Invalid LINE pragma: " ++ show r) p, advc 8 p, xs)+scan :: Options -> Lexer Token+scan opts+ = scan where- (r,rs) = span isDigit xs- (s, rs') = span (/= '"') (drop 2 rs)- p' = Pos (read r - 1) (column p) s -- LINE pragma indicates the line number of the /next/ line!- - isOkBegin (' ' : '"' : _) = True- isOkBegin _ = False- - isOkEnd ('"' : ' ' : '-' : '}' : _) = True- isOkEnd _ = False-scanBeginOfLine p xs- = scan p xs+ keywords' = if lcKeywords opts+ then map (map toLower) keywords+ else keywords+ mkKeyword s | s `elem` lowercaseKeywords = s+ | otherwise = map toUpper s+ + scan :: Lexer Token + scan p [] = Nothing + scan p ('-':'-':xs) = let (com,rest) = span (/= '\n') xs + in advc' (2+length com) p scan rest + scan p ('{':'-':xs) = advc' 2 p (ncomment scan) xs + scan p ('{' :xs) = advc' 1 p codescrap xs + scan p ('\CR':xs) = case xs of + '\LF':ys -> newl' p scanBeginOfLine ys --ms newline + _ -> newl' p scanBeginOfLine xs --mac newline + scan p ('\LF':xs) = newl' p scanBeginOfLine xs --unix newline + scan p (x:xs) | isSpace x = updPos' x p scan xs + scan p xs = Just (scan' xs) + where scan' ('.' :rs) = (reserved "." p, advc 1 p, rs) + scan' ('@' :rs) = (reserved "@" p, advc 1 p, rs) + scan' (',' :rs) = (reserved "," p, advc 1 p, rs) + scan' ('_' :rs) = (reserved "_" p, advc 1 p, rs) + scan' ('~' :rs) = (reserved "~" p, advc 1 p, rs) + scan' ('<' :rs) = (reserved "<" p, advc 1 p, rs) + scan' ('[' :rs) = (reserved "[" p, advc 1 p, rs) + scan' (']' :rs) = (reserved "]" p, advc 1 p, rs) + scan' ('(' :rs) = (reserved "(" p, advc 1 p, rs) + scan' (')' :rs) = (reserved ")" p, advc 1 p, rs) + -- scan' ('{' :rs) = (OBrace p, advc 1 p, rs) + -- scan' ('}' :rs) = (CBrace p, advc 1 p, rs) + + scan' ('\"' :rs) = let isOk c = c /= '"' && c /= '\n' + (str,rest) = span isOk rs + in if null rest || head rest /= '"' + then (errToken "unterminated string literal" p + , advc (1+length str) p,rest) + else (valueToken TkString str p, advc (2+length str) p, tail rest) + + scan' ('=' : '>' : rs) = (reserved "=>" p, advc 2 p, rs) + scan' ('=' :rs) = (reserved "=" p, advc 1 p, rs) + scan' (':':'=':rs) = (reserved ":=" p, advc 2 p, rs) + + scan' (':' :rs) | not (doubleColons opts) = (reserved ":" p, advc 1 p, rs)+ scan' (':':':':rs) | doubleColons opts = (reserved "::" p, advc 1 p, rs) + scan' ('|' :rs) = (reserved "|" p, advc 1 p, rs) + + scan' ('/':'\\':rs) = (reserved "/\\" p, advc 2 p, rs) + scan' ('-':'>' :rs) = (reserved "->" p, advc 2 p, rs) + scan' ('-' :rs) = (reserved "-" p, advc 1 p, rs) + scan' ('*' :rs) = (reserved "*" p, advc 1 p, rs) + + scan' (x:rs) | isLower x = let (var,rest) = ident rs + str = (x:var) + tok | str `elem` keywords' = reserved (mkKeyword str) + | otherwise = valueToken TkVarid str + in (tok p, advc (length var+1) p, rest) + | isUpper x = let (var,rest) = ident rs + str = (x:var) + tok | str `elem` keywords' = reserved (mkKeyword str) + | otherwise = valueToken TkConid str + in (tok p, advc (length var+1) p,rest) + | otherwise = (errToken ("unexpected character " ++ show x) p, advc 1 p, rs) + + scanBeginOfLine :: Lexer Token + scanBeginOfLine p ('{' : '-' : ' ' : 'L' : 'I' : 'N' : 'E' : ' ' : xs) + | isOkBegin rs && isOkEnd rs' + = scan (advc (8 + length r + 2 + length s + 4) p') (drop 4 rs') + | otherwise + = Just (errToken ("Invalid LINE pragma: " ++ show r) p, advc 8 p, xs) + where + (r,rs) = span isDigit xs + (s, rs') = span (/= '"') (drop 2 rs) + p' = Pos (read r - 1) (column p) s -- LINE pragma indicates the line number of the /next/ line! + + isOkBegin (' ' : '"' : _) = True + isOkBegin _ = False + + isOkEnd ('"' : ' ' : '-' : '}' : _) = True + isOkEnd _ = False + scanBeginOfLine p xs + = scan p xs ident = span isValid - where isValid x = isAlphaNum x || x =='_' || x == '\'' -keywords = [ "DATA", "EXT", "ATTR", "SEM","TYPE", "USE", "loc","lhs", "inst", "INCLUDE" + where isValid x = isAlphaNum x || x =='_' || x == '\''+lowercaseKeywords = ["loc","lhs", "inst"] +keywords = lowercaseKeywords +++ [ "DATA", "EXT", "ATTR", "SEM","TYPE", "USE", "INCLUDE" , "SET","DERIVING","FOR", "WRAPPER", "MAYBE", "EITHER", "MAP", "INTMAP" - , "PRAGMA", "SEMPRAGMA", "MODULE", "ATTACH", "UNIQUEREF" + , "PRAGMA", "SEMPRAGMA", "MODULE", "ATTACH", "UNIQUEREF", "INH", "SYN" ] ncomment c p ('-':'}':xs) = advc' 2 p c xs
src/TokenDef.hs view
@@ -1,6 +1,7 @@- +{-# OPTIONS -fglasgow-exts #-} module TokenDef where +import GHC.Prim import UU.Scanner.Token import UU.Scanner.GenToken import UU.Scanner.GenTokenOrd @@ -13,17 +14,17 @@ instance Symbol Token where - deleteCost (Reserved key _) = case key of - "DATA" -> 7 - "EXT" -> 7 - "ATTR" -> 7 - "SEM" -> 7 - "USE" -> 7 - "INCLUDE" -> 7 - _ -> 5 + deleteCost (Reserved key _) = case key of+ "DATA" -> 7#+ "EXT" -> 7# + "ATTR" -> 7# + "SEM" -> 7# + "USE" -> 7# + "INCLUDE" -> 7# + _ -> 5# deleteCost (ValToken v _ _) = case v of - TkError -> 0 - _ -> 5 + TkError -> 0# + _ -> 5# tokensToStrings :: [HsToken] -> [(Pos,String)]
src/Version.hs view
@@ -1,4 +1,4 @@ module Version where banner :: String -banner = "Attribute Grammar compiler / HUT project. Version 0.9.7" +banner = "Attribute Grammar compiler / HUT project. Version 0.9.10"
uuagc.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.2 build-type: Simple name: uuagc-version: 0.9.7+version: 0.9.10 license: GPL license-file: LICENSE maintainer: Arie Middelkoop <ariem@cs.uu.nl>@@ -13,10 +13,17 @@ copyright: Universiteit Utrecht extra-source-files: README, uuagc.cabal-for-ghc-6.6 -flag small_base- description: Choose the new smaller, split-up base package.+flag compatibility1+ description: compatibility flag.+flag compatibility2+ description: compatibility flag. executable uuagc- if flag(small_base)+ if flag(compatibility1)+ build-depends: base >= 4, ghc-prim+ else+ build-depends: base < 4++ if flag(compatibility2) build-depends: base >= 3, containers, directory, array else build-depends: base < 3
uuagc.cabal-for-ghc-6.6 view
@@ -1,5 +1,5 @@ name: uuagc-version: 0.9.7+version: 0.9.10 license: GPL license-file: LICENSE maintainer: Arie Middelkoop <ariem@cs.uu.nl>