diff --git a/src-derived/PrintErrorMessages.hs b/src-derived/PrintErrorMessages.hs --- a/src-derived/PrintErrorMessages.hs +++ b/src-derived/PrintErrorMessages.hs @@ -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 diff --git a/src-derived/Transform.hs b/src-derived/Transform.hs --- a/src-derived/Transform.hs +++ b/src-derived/Transform.hs @@ -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))) diff --git a/src/Ag.hs b/src/Ag.hs --- a/src/Ag.hs +++ b/src/Ag.hs @@ -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} diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -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} diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -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" diff --git a/src/Scanner.hs b/src/Scanner.hs --- a/src/Scanner.hs +++ b/src/Scanner.hs @@ -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 diff --git a/src/TokenDef.hs b/src/TokenDef.hs --- a/src/TokenDef.hs +++ b/src/TokenDef.hs @@ -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)] diff --git a/src/Version.hs b/src/Version.hs --- a/src/Version.hs +++ b/src/Version.hs @@ -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" diff --git a/uuagc.cabal b/uuagc.cabal --- a/uuagc.cabal +++ b/uuagc.cabal @@ -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 @@ -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 diff --git a/uuagc.cabal-for-ghc-6.6 b/uuagc.cabal-for-ghc-6.6 --- a/uuagc.cabal-for-ghc-6.6 +++ b/uuagc.cabal-for-ghc-6.6 @@ -1,5 +1,5 @@ name: uuagc -version: 0.9.7 +version: 0.9.10 license: GPL license-file: LICENSE maintainer: Arie Middelkoop