diff --git a/src-derived/ConcreteSyntax.hs b/src-derived/ConcreteSyntax.hs --- a/src-derived/ConcreteSyntax.hs +++ b/src-derived/ConcreteSyntax.hs @@ -189,6 +189,7 @@ child ident : {Identifier} child rhs : {Expression} alternative Def: + child pos : {Pos} child pattern : {Pattern} child rhs : {Expression} child owrt : {Bool} @@ -204,7 +205,7 @@ data SemDef = AroundDef (Identifier) (Expression) | AttrOrderBefore ([(Identifier,Identifier)]) ([(Identifier,Identifier)]) | AugmentDef (Identifier) (Expression) - | Def (Pattern) (Expression) (Bool) + | Def (Pos) (Pattern) (Expression) (Bool) | SemPragma ([NontermIdent]) | TypeDef (Identifier) (Type) | UniqueDef (Identifier) (Identifier) diff --git a/src-derived/Transform.hs b/src-derived/Transform.hs --- a/src-derived/Transform.hs +++ b/src-derived/Transform.hs @@ -5070,6 +5070,7 @@ child ident : {Identifier} child rhs : {Expression} alternative Def: + child pos : {Pos} child pattern : Pattern child rhs : {Expression} child owrt : {Bool} @@ -5091,8 +5092,8 @@ (sem_SemDef_AttrOrderBefore _before _after ) sem_SemDef (AugmentDef _ident _rhs ) = (sem_SemDef_AugmentDef _ident _rhs ) -sem_SemDef (Def _pattern _rhs _owrt ) = - (sem_SemDef_Def (sem_Pattern _pattern ) _rhs _owrt ) +sem_SemDef (Def _pos _pattern _rhs _owrt ) = + (sem_SemDef_Def _pos (sem_Pattern _pattern ) _rhs _owrt ) sem_SemDef (SemPragma _names ) = (sem_SemDef_SemPragma _names ) sem_SemDef (TypeDef _ident _tp ) = @@ -5126,42 +5127,42 @@ _lhsOaroundInfos = {-# LINE 952 "Transform.ag" #-} [ (ident_, rhs_) ] - {-# LINE 5130 "Transform.hs" #-} + {-# LINE 5131 "Transform.hs" #-} -- use rule "Transform.ag"(line 884, column 40) _lhsOaugmentInfos = {-# LINE 884 "Transform.ag" #-} [] - {-# LINE 5135 "Transform.hs" #-} + {-# LINE 5136 "Transform.hs" #-} -- use rule "Transform.ag"(line 955, column 55) _lhsOdefinedInsts = {-# LINE 955 "Transform.ag" #-} [] - {-# LINE 5140 "Transform.hs" #-} + {-# LINE 5141 "Transform.hs" #-} -- use rule "Transform.ag"(line 747, column 44) _lhsOorderDepsCollect = {-# LINE 747 "Transform.ag" #-} Set.empty - {-# LINE 5145 "Transform.hs" #-} + {-# LINE 5146 "Transform.hs" #-} -- use rule "Transform.ag"(line 716, column 46) _lhsOpragmaNamesCollect = {-# LINE 716 "Transform.ag" #-} [] - {-# LINE 5150 "Transform.hs" #-} + {-# LINE 5151 "Transform.hs" #-} -- use rule "Transform.ag"(line 881, column 40) _lhsOruleInfos = {-# LINE 881 "Transform.ag" #-} [] - {-# LINE 5155 "Transform.hs" #-} + {-# LINE 5156 "Transform.hs" #-} -- use rule "Transform.ag"(line 882, column 40) _lhsOsigInfos = {-# LINE 882 "Transform.ag" #-} [] - {-# LINE 5160 "Transform.hs" #-} + {-# LINE 5161 "Transform.hs" #-} -- use rule "Transform.ag"(line 883, column 40) _lhsOuniqueInfos = {-# LINE 883 "Transform.ag" #-} [] - {-# LINE 5165 "Transform.hs" #-} + {-# LINE 5166 "Transform.hs" #-} in ( _lhsOaroundInfos,_lhsOaugmentInfos,_lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)) ) sem_SemDef_AttrOrderBefore :: ([(Identifier,Identifier)]) -> ([(Identifier,Identifier)]) -> @@ -5179,47 +5180,47 @@ _dependency = {-# LINE 751 "Transform.ag" #-} [ Dependency b a | b <- before_, a <- after_ ] - {-# LINE 5183 "Transform.hs" #-} + {-# LINE 5184 "Transform.hs" #-} -- "Transform.ag"(line 752, column 7) _lhsOorderDepsCollect = {-# LINE 752 "Transform.ag" #-} Set.fromList _dependency - {-# LINE 5188 "Transform.hs" #-} + {-# LINE 5189 "Transform.hs" #-} -- use rule "Transform.ag"(line 885, column 40) _lhsOaroundInfos = {-# LINE 885 "Transform.ag" #-} [] - {-# LINE 5193 "Transform.hs" #-} + {-# LINE 5194 "Transform.hs" #-} -- use rule "Transform.ag"(line 884, column 40) _lhsOaugmentInfos = {-# LINE 884 "Transform.ag" #-} [] - {-# LINE 5198 "Transform.hs" #-} + {-# LINE 5199 "Transform.hs" #-} -- use rule "Transform.ag"(line 955, column 55) _lhsOdefinedInsts = {-# LINE 955 "Transform.ag" #-} [] - {-# LINE 5203 "Transform.hs" #-} + {-# LINE 5204 "Transform.hs" #-} -- use rule "Transform.ag"(line 716, column 46) _lhsOpragmaNamesCollect = {-# LINE 716 "Transform.ag" #-} [] - {-# LINE 5208 "Transform.hs" #-} + {-# LINE 5209 "Transform.hs" #-} -- use rule "Transform.ag"(line 881, column 40) _lhsOruleInfos = {-# LINE 881 "Transform.ag" #-} [] - {-# LINE 5213 "Transform.hs" #-} + {-# LINE 5214 "Transform.hs" #-} -- use rule "Transform.ag"(line 882, column 40) _lhsOsigInfos = {-# LINE 882 "Transform.ag" #-} [] - {-# LINE 5218 "Transform.hs" #-} + {-# LINE 5219 "Transform.hs" #-} -- use rule "Transform.ag"(line 883, column 40) _lhsOuniqueInfos = {-# LINE 883 "Transform.ag" #-} [] - {-# LINE 5223 "Transform.hs" #-} + {-# LINE 5224 "Transform.hs" #-} in ( _lhsOaroundInfos,_lhsOaugmentInfos,_lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)) ) sem_SemDef_AugmentDef :: Identifier -> Expression -> @@ -5237,48 +5238,49 @@ _lhsOaugmentInfos = {-# LINE 949 "Transform.ag" #-} [ (ident_, rhs_) ] - {-# LINE 5241 "Transform.hs" #-} + {-# LINE 5242 "Transform.hs" #-} -- use rule "Transform.ag"(line 885, column 40) _lhsOaroundInfos = {-# LINE 885 "Transform.ag" #-} [] - {-# LINE 5246 "Transform.hs" #-} + {-# LINE 5247 "Transform.hs" #-} -- use rule "Transform.ag"(line 955, column 55) _lhsOdefinedInsts = {-# LINE 955 "Transform.ag" #-} [] - {-# LINE 5251 "Transform.hs" #-} + {-# LINE 5252 "Transform.hs" #-} -- use rule "Transform.ag"(line 747, column 44) _lhsOorderDepsCollect = {-# LINE 747 "Transform.ag" #-} Set.empty - {-# LINE 5256 "Transform.hs" #-} + {-# LINE 5257 "Transform.hs" #-} -- use rule "Transform.ag"(line 716, column 46) _lhsOpragmaNamesCollect = {-# LINE 716 "Transform.ag" #-} [] - {-# LINE 5261 "Transform.hs" #-} + {-# LINE 5262 "Transform.hs" #-} -- use rule "Transform.ag"(line 881, column 40) _lhsOruleInfos = {-# LINE 881 "Transform.ag" #-} [] - {-# LINE 5266 "Transform.hs" #-} + {-# LINE 5267 "Transform.hs" #-} -- use rule "Transform.ag"(line 882, column 40) _lhsOsigInfos = {-# LINE 882 "Transform.ag" #-} [] - {-# LINE 5271 "Transform.hs" #-} + {-# LINE 5272 "Transform.hs" #-} -- use rule "Transform.ag"(line 883, column 40) _lhsOuniqueInfos = {-# LINE 883 "Transform.ag" #-} [] - {-# LINE 5276 "Transform.hs" #-} + {-# LINE 5277 "Transform.hs" #-} in ( _lhsOaroundInfos,_lhsOaugmentInfos,_lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)) ) -sem_SemDef_Def :: T_Pattern -> +sem_SemDef_Def :: Pos -> + T_Pattern -> Expression -> Bool -> T_SemDef -sem_SemDef_Def (T_Pattern pattern_ ) rhs_ owrt_ = +sem_SemDef_Def pos_ (T_Pattern pattern_ ) rhs_ owrt_ = (T_SemDef (let _lhsOruleInfos :: ([RuleInfo]) _lhsOaroundInfos :: ([AroundInfo]) _lhsOaugmentInfos :: ([AugmentInfo]) @@ -5296,42 +5298,42 @@ _lhsOruleInfos = {-# LINE 940 "Transform.ag" #-} [ (_patternIpatunder, rhs_, _patternIdefinedAttrs, owrt_, show _patternIstpos) ] - {-# LINE 5300 "Transform.hs" #-} + {-# LINE 5302 "Transform.hs" #-} -- use rule "Transform.ag"(line 885, column 40) _lhsOaroundInfos = {-# LINE 885 "Transform.ag" #-} [] - {-# LINE 5305 "Transform.hs" #-} + {-# LINE 5307 "Transform.hs" #-} -- use rule "Transform.ag"(line 884, column 40) _lhsOaugmentInfos = {-# LINE 884 "Transform.ag" #-} [] - {-# LINE 5310 "Transform.hs" #-} + {-# LINE 5312 "Transform.hs" #-} -- use rule "Transform.ag"(line 955, column 55) _lhsOdefinedInsts = {-# LINE 955 "Transform.ag" #-} _patternIdefinedInsts - {-# LINE 5315 "Transform.hs" #-} + {-# LINE 5317 "Transform.hs" #-} -- use rule "Transform.ag"(line 747, column 44) _lhsOorderDepsCollect = {-# LINE 747 "Transform.ag" #-} Set.empty - {-# LINE 5320 "Transform.hs" #-} + {-# LINE 5322 "Transform.hs" #-} -- use rule "Transform.ag"(line 716, column 46) _lhsOpragmaNamesCollect = {-# LINE 716 "Transform.ag" #-} [] - {-# LINE 5325 "Transform.hs" #-} + {-# LINE 5327 "Transform.hs" #-} -- use rule "Transform.ag"(line 882, column 40) _lhsOsigInfos = {-# LINE 882 "Transform.ag" #-} [] - {-# LINE 5330 "Transform.hs" #-} + {-# LINE 5332 "Transform.hs" #-} -- use rule "Transform.ag"(line 883, column 40) _lhsOuniqueInfos = {-# LINE 883 "Transform.ag" #-} [] - {-# LINE 5335 "Transform.hs" #-} + {-# LINE 5337 "Transform.hs" #-} ( _patternIcopy,_patternIdefinedAttrs,_patternIdefinedInsts,_patternIpatunder,_patternIstpos) = (pattern_ ) in ( _lhsOaroundInfos,_lhsOaugmentInfos,_lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)) ) @@ -5350,42 +5352,42 @@ _lhsOpragmaNamesCollect = {-# LINE 720 "Transform.ag" #-} names_ - {-# LINE 5354 "Transform.hs" #-} + {-# LINE 5356 "Transform.hs" #-} -- use rule "Transform.ag"(line 885, column 40) _lhsOaroundInfos = {-# LINE 885 "Transform.ag" #-} [] - {-# LINE 5359 "Transform.hs" #-} + {-# LINE 5361 "Transform.hs" #-} -- use rule "Transform.ag"(line 884, column 40) _lhsOaugmentInfos = {-# LINE 884 "Transform.ag" #-} [] - {-# LINE 5364 "Transform.hs" #-} + {-# LINE 5366 "Transform.hs" #-} -- use rule "Transform.ag"(line 955, column 55) _lhsOdefinedInsts = {-# LINE 955 "Transform.ag" #-} [] - {-# LINE 5369 "Transform.hs" #-} + {-# LINE 5371 "Transform.hs" #-} -- use rule "Transform.ag"(line 747, column 44) _lhsOorderDepsCollect = {-# LINE 747 "Transform.ag" #-} Set.empty - {-# LINE 5374 "Transform.hs" #-} + {-# LINE 5376 "Transform.hs" #-} -- use rule "Transform.ag"(line 881, column 40) _lhsOruleInfos = {-# LINE 881 "Transform.ag" #-} [] - {-# LINE 5379 "Transform.hs" #-} + {-# LINE 5381 "Transform.hs" #-} -- use rule "Transform.ag"(line 882, column 40) _lhsOsigInfos = {-# LINE 882 "Transform.ag" #-} [] - {-# LINE 5384 "Transform.hs" #-} + {-# LINE 5386 "Transform.hs" #-} -- use rule "Transform.ag"(line 883, column 40) _lhsOuniqueInfos = {-# LINE 883 "Transform.ag" #-} [] - {-# LINE 5389 "Transform.hs" #-} + {-# LINE 5391 "Transform.hs" #-} in ( _lhsOaroundInfos,_lhsOaugmentInfos,_lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)) ) sem_SemDef_TypeDef :: Identifier -> Type -> @@ -5403,42 +5405,42 @@ _lhsOsigInfos = {-# LINE 943 "Transform.ag" #-} [ (ident_, tp_) ] - {-# LINE 5407 "Transform.hs" #-} + {-# LINE 5409 "Transform.hs" #-} -- use rule "Transform.ag"(line 885, column 40) _lhsOaroundInfos = {-# LINE 885 "Transform.ag" #-} [] - {-# LINE 5412 "Transform.hs" #-} + {-# LINE 5414 "Transform.hs" #-} -- use rule "Transform.ag"(line 884, column 40) _lhsOaugmentInfos = {-# LINE 884 "Transform.ag" #-} [] - {-# LINE 5417 "Transform.hs" #-} + {-# LINE 5419 "Transform.hs" #-} -- use rule "Transform.ag"(line 955, column 55) _lhsOdefinedInsts = {-# LINE 955 "Transform.ag" #-} [] - {-# LINE 5422 "Transform.hs" #-} + {-# LINE 5424 "Transform.hs" #-} -- use rule "Transform.ag"(line 747, column 44) _lhsOorderDepsCollect = {-# LINE 747 "Transform.ag" #-} Set.empty - {-# LINE 5427 "Transform.hs" #-} + {-# LINE 5429 "Transform.hs" #-} -- use rule "Transform.ag"(line 716, column 46) _lhsOpragmaNamesCollect = {-# LINE 716 "Transform.ag" #-} [] - {-# LINE 5432 "Transform.hs" #-} + {-# LINE 5434 "Transform.hs" #-} -- use rule "Transform.ag"(line 881, column 40) _lhsOruleInfos = {-# LINE 881 "Transform.ag" #-} [] - {-# LINE 5437 "Transform.hs" #-} + {-# LINE 5439 "Transform.hs" #-} -- use rule "Transform.ag"(line 883, column 40) _lhsOuniqueInfos = {-# LINE 883 "Transform.ag" #-} [] - {-# LINE 5442 "Transform.hs" #-} + {-# LINE 5444 "Transform.hs" #-} in ( _lhsOaroundInfos,_lhsOaugmentInfos,_lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)) ) sem_SemDef_UniqueDef :: Identifier -> Identifier -> @@ -5456,42 +5458,42 @@ _lhsOuniqueInfos = {-# LINE 946 "Transform.ag" #-} [ (ident_, ref_) ] - {-# LINE 5460 "Transform.hs" #-} + {-# LINE 5462 "Transform.hs" #-} -- use rule "Transform.ag"(line 885, column 40) _lhsOaroundInfos = {-# LINE 885 "Transform.ag" #-} [] - {-# LINE 5465 "Transform.hs" #-} + {-# LINE 5467 "Transform.hs" #-} -- use rule "Transform.ag"(line 884, column 40) _lhsOaugmentInfos = {-# LINE 884 "Transform.ag" #-} [] - {-# LINE 5470 "Transform.hs" #-} + {-# LINE 5472 "Transform.hs" #-} -- use rule "Transform.ag"(line 955, column 55) _lhsOdefinedInsts = {-# LINE 955 "Transform.ag" #-} [] - {-# LINE 5475 "Transform.hs" #-} + {-# LINE 5477 "Transform.hs" #-} -- use rule "Transform.ag"(line 747, column 44) _lhsOorderDepsCollect = {-# LINE 747 "Transform.ag" #-} Set.empty - {-# LINE 5480 "Transform.hs" #-} + {-# LINE 5482 "Transform.hs" #-} -- use rule "Transform.ag"(line 716, column 46) _lhsOpragmaNamesCollect = {-# LINE 716 "Transform.ag" #-} [] - {-# LINE 5485 "Transform.hs" #-} + {-# LINE 5487 "Transform.hs" #-} -- use rule "Transform.ag"(line 881, column 40) _lhsOruleInfos = {-# LINE 881 "Transform.ag" #-} [] - {-# LINE 5490 "Transform.hs" #-} + {-# LINE 5492 "Transform.hs" #-} -- use rule "Transform.ag"(line 882, column 40) _lhsOsigInfos = {-# LINE 882 "Transform.ag" #-} [] - {-# LINE 5495 "Transform.hs" #-} + {-# LINE 5497 "Transform.hs" #-} in ( _lhsOaroundInfos,_lhsOaugmentInfos,_lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)) ) -- SemDefs ----------------------------------------------------- {- @@ -5559,42 +5561,42 @@ _lhsOaroundInfos = {-# LINE 885 "Transform.ag" #-} _hdIaroundInfos ++ _tlIaroundInfos - {-# LINE 5563 "Transform.hs" #-} + {-# LINE 5565 "Transform.hs" #-} -- use rule "Transform.ag"(line 884, column 40) _lhsOaugmentInfos = {-# LINE 884 "Transform.ag" #-} _hdIaugmentInfos ++ _tlIaugmentInfos - {-# LINE 5568 "Transform.hs" #-} + {-# LINE 5570 "Transform.hs" #-} -- use rule "Transform.ag"(line 955, column 55) _lhsOdefinedInsts = {-# LINE 955 "Transform.ag" #-} _hdIdefinedInsts ++ _tlIdefinedInsts - {-# LINE 5573 "Transform.hs" #-} + {-# LINE 5575 "Transform.hs" #-} -- use rule "Transform.ag"(line 747, column 44) _lhsOorderDepsCollect = {-# LINE 747 "Transform.ag" #-} _hdIorderDepsCollect `Set.union` _tlIorderDepsCollect - {-# LINE 5578 "Transform.hs" #-} + {-# LINE 5580 "Transform.hs" #-} -- use rule "Transform.ag"(line 716, column 46) _lhsOpragmaNamesCollect = {-# LINE 716 "Transform.ag" #-} _hdIpragmaNamesCollect ++ _tlIpragmaNamesCollect - {-# LINE 5583 "Transform.hs" #-} + {-# LINE 5585 "Transform.hs" #-} -- use rule "Transform.ag"(line 881, column 40) _lhsOruleInfos = {-# LINE 881 "Transform.ag" #-} _hdIruleInfos ++ _tlIruleInfos - {-# LINE 5588 "Transform.hs" #-} + {-# LINE 5590 "Transform.hs" #-} -- use rule "Transform.ag"(line 882, column 40) _lhsOsigInfos = {-# LINE 882 "Transform.ag" #-} _hdIsigInfos ++ _tlIsigInfos - {-# LINE 5593 "Transform.hs" #-} + {-# LINE 5595 "Transform.hs" #-} -- use rule "Transform.ag"(line 883, column 40) _lhsOuniqueInfos = {-# LINE 883 "Transform.ag" #-} _hdIuniqueInfos ++ _tlIuniqueInfos - {-# LINE 5598 "Transform.hs" #-} + {-# LINE 5600 "Transform.hs" #-} ( _hdIaroundInfos,_hdIaugmentInfos,_hdIdefinedInsts,_hdIorderDepsCollect,_hdIpragmaNamesCollect,_hdIruleInfos,_hdIsigInfos,_hdIuniqueInfos) = (hd_ ) ( _tlIaroundInfos,_tlIaugmentInfos,_tlIdefinedInsts,_tlIorderDepsCollect,_tlIpragmaNamesCollect,_tlIruleInfos,_tlIsigInfos,_tlIuniqueInfos) = @@ -5614,40 +5616,40 @@ _lhsOaroundInfos = {-# LINE 885 "Transform.ag" #-} [] - {-# LINE 5618 "Transform.hs" #-} + {-# LINE 5620 "Transform.hs" #-} -- use rule "Transform.ag"(line 884, column 40) _lhsOaugmentInfos = {-# LINE 884 "Transform.ag" #-} [] - {-# LINE 5623 "Transform.hs" #-} + {-# LINE 5625 "Transform.hs" #-} -- use rule "Transform.ag"(line 955, column 55) _lhsOdefinedInsts = {-# LINE 955 "Transform.ag" #-} [] - {-# LINE 5628 "Transform.hs" #-} + {-# LINE 5630 "Transform.hs" #-} -- use rule "Transform.ag"(line 747, column 44) _lhsOorderDepsCollect = {-# LINE 747 "Transform.ag" #-} Set.empty - {-# LINE 5633 "Transform.hs" #-} + {-# LINE 5635 "Transform.hs" #-} -- use rule "Transform.ag"(line 716, column 46) _lhsOpragmaNamesCollect = {-# LINE 716 "Transform.ag" #-} [] - {-# LINE 5638 "Transform.hs" #-} + {-# LINE 5640 "Transform.hs" #-} -- use rule "Transform.ag"(line 881, column 40) _lhsOruleInfos = {-# LINE 881 "Transform.ag" #-} [] - {-# LINE 5643 "Transform.hs" #-} + {-# LINE 5645 "Transform.hs" #-} -- use rule "Transform.ag"(line 882, column 40) _lhsOsigInfos = {-# LINE 882 "Transform.ag" #-} [] - {-# LINE 5648 "Transform.hs" #-} + {-# LINE 5650 "Transform.hs" #-} -- use rule "Transform.ag"(line 883, column 40) _lhsOuniqueInfos = {-# LINE 883 "Transform.ag" #-} [] - {-# LINE 5653 "Transform.hs" #-} + {-# LINE 5655 "Transform.hs" #-} in ( _lhsOaroundInfos,_lhsOaugmentInfos,_lhsOdefinedInsts,_lhsOorderDepsCollect,_lhsOpragmaNamesCollect,_lhsOruleInfos,_lhsOsigInfos,_lhsOuniqueInfos)) ) diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -43,23 +43,217 @@ 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 + = 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 opts searchPath) files - let (ess,fss,allfss, msgs) = unzip4 res - 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) + steps = parse pElemsFiles tokens + stop (_,fs,_,_) = null fs + cont (es,fs,allfs,msg) + = 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) + let (Pair (es,fls) _ ,mesg) = evalStepsMessages steps + let allfs = files ++ fls + loopp stop cont (es,allfs,allfs,mesg) + where + + -- + -- Option dependent AG Parsers inlined here + -- to have access to the opts + -- while retaining sharing + -- + + 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 opts p2 inp2) + steps = k ( rest) + in (val (acc sc) steps) + ) + in anaDynE (mkPR (P (p ), R (p (const id)))) + + pElems :: AGParser Elems + pElems = pList_ng pElem + + pComplexType = List <$> pBracks pTypeEncapsulated + <|> Maybe <$ pMAYBE <*> pType + <|> Either <$ pEITHER <*> pType <*> pType + <|> Map <$ pMAP <*> pTypePrimitive <*> pType + <|> IntMap <$ pINTMAP <*> pType + <|> tuple <$> pParens (pListSep pComma field) + where field = (,) <$> ((Just <$> pIdentifier <* pTypeColon) `opt` Nothing) <*> pTypeEncapsulated + tuple xs = Tuple [(fromMaybe (Ident ("x"++show n) noPos) f, t) + | (n,(f,t)) <- zip [1..] xs + ] + + pElem :: AGParser Elem + pElem + = Data <$> pDATA + <*> pOptClassContext + <*> pNontSet + <*> pList pIdentifier + <*> pOptAttrs + <*> pAlts + <*> pSucceed False + <|> Attr <$> pATTR + <*> pOptClassContext + <*> pNontSet + <*> pAttrs + <|> Type <$> pTYPE + <*> pOptClassContext + <*> pIdentifierU + <*> pList pIdentifier + <* pEquals + <*> pComplexType + <|> Sem <$> pSEM + <*> pOptClassContext + <*> pNontSet + <*> pOptAttrs + <*> pSemAlts + <|> 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" + where codeBlock nm mbNt (txt,pos) = Txt pos nm mbNt (lines txt) + + + pAttrs :: AGParser Attrs + pAttrs + = Attrs <$> pOBrackPos <*> (concat <$> pList pInhAttrNames "inherited attribute declarations") + <* pBar <*> (concat <$> pList pAttrNames "chained attribute declarations" ) + <* pBar <*> (concat <$> pList pAttrNames "synthesised attribute declarations" ) + <* pCBrack + <|> (\ds -> Attrs (fst $ head ds) [n | (_,(nms,_,_)) <- ds, n <- nms] [n | (_,(_,nms,_)) <- ds, n <- nms] [n | (_,(_,_,nms)) <- ds, n <- nms]) <$> pList1 pSingleAttrDefs + + pSingleAttrDefs :: AGParser (Pos, (AttrNames, AttrNames, AttrNames)) + pSingleAttrDefs + = (\p is -> (p, (is,[],[]))) <$> pINH <*> pList1Sep pComma pSingleInhAttrDef + <|> (\p is -> (p, ([],[],is))) <$> pSYN <*> pList1Sep pComma pSingleSynAttrDef + <|> (\p is -> (p, ([],is,[]))) <$> pCHN <*> pList1Sep pComma pSingleChnAttrDef + + pSingleInhAttrDef :: AGParser (Identifier,Type,(String,String,String)) + pSingleInhAttrDef + = (\v tp -> (v,tp,("","",""))) <$> pIdentifier <* pTypeColon <*> pType "inh attribute declaration" + + pSingleSynAttrDef :: AGParser (Identifier,Type,(String,String,String)) + pSingleSynAttrDef + = (\v u tp -> (v,tp,u)) <$> pIdentifier <*> pUse <* pTypeColon <*> pType "syn attribute declaration" + + pSingleChnAttrDef :: AGParser (Identifier,Type,(String,String,String)) + pSingleChnAttrDef + = (\v tp -> (v,tp,("","",""))) <$> pIdentifier <* pTypeColon <*> pType "chn attribute declaration" + + pOptAttrs :: AGParser Attrs + pOptAttrs = pAttrs `opt` Attrs noPos [] [] [] + + pInhAttrNames :: AGParser AttrNames + pInhAttrNames + = (\vs tp -> map (\v -> (v,tp,("","",""))) vs) + <$> pIdentifiers <* pTypeColon <*> pType "attribute declarations" + + pAttrNames :: AGParser AttrNames + pAttrNames + = (\vs use tp -> map (\v -> (v,tp,use)) vs) + <$> pIdentifiers <*> pUse <* pTypeColon <*> pType "attribute declarations" + + 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 <* pTypeColon <*> pType + <|> (\s -> [(Ident (mklower (getName s)) (getPos s) ,NT s [])]) <$> pIdentifierU + + pSemAlt :: AGParser SemAlt + pSemAlt = SemAlt <$> pBar <*> pConstructorSet <*> pSemDefs "SEM alternative" + + pSemAlts :: AGParser SemAlts + pSemAlts = pList pSemAlt "SEM alternatives" + + pSemDef :: AGParser [SemDef] + pSemDef + = (\x fs -> map ($ x) fs)<$> pFieldIdentifier <*> pList1 pAttrDef + <|> pLOC *> pList1 pLocDecl + <|> pINST *> pList1 pInstDecl + <|> pSEMPRAGMA *> pList1 (SemPragma <$> pNames) + <|> (\n e -> [AugmentDef n e]) <$ pAugmentToken <*> pIdentifier <* pAssign <*> pExpr + <|> (\n e -> [AroundDef n e]) <$ pAROUND <*> pIdentifier <* pAssign <*> pExpr + <|> (\a b -> [AttrOrderBefore a [b]]) <$> pList1 pAttr <* pSmaller <*> pAttr + <|> (\pat (owrt,pos) exp -> [Def pos (pat ()) exp owrt]) <$> pPattern (const <$> pAttr) <*> pAssignPos <*> pExpr + + pAttrDef :: AGParser (Identifier -> SemDef) + pAttrDef + = (\pat (owrt,pos) exp fld -> Def pos (pat fld) exp owrt) + <$ pDot <*> pattern <*> pAssignPos <*> pExpr + where pattern = pPattern pVar + <|> (\ir a fld -> ir $ Alias fld a (Underscore noPos) []) <$> ((Irrefutable <$ pTilde) `opt` id) <*> pIdentifier + + pLocDecl :: AGParser SemDef + pLocDecl = pDot <**> (pIdentifier <**> (pTypeColon <**> ( (\tp _ ident _ -> TypeDef ident tp) <$> pLocType + <|> (\ref _ ident _ -> UniqueDef ident ref) <$ pUNIQUEREF <*> pIdentifier ))) + + + pInstDecl :: AGParser SemDef + pInstDecl = (\ident tp -> TypeDef ident tp) + <$ pDot <*> pIdentifier <* pTypeColon <*> pTypeNt + + pSemDefs :: AGParser SemDefs + pSemDefs = concat <$> pList_ng pSemDef "attribute rules" + + pExpr :: AGParser Expression + pExpr = (\(str,pos) -> Expression pos (lexTokens pos str)) <$> pCodescrapL "an expression" + + pTypeColon :: AGParser Pos + pTypeColon + = if doubleColons opts + then pDoubleColon + else pColon + + -- + -- End of AG Parser + -- + resolveFile :: [FilePath] -> FilePath -> IO FilePath resolveFile path fname = search (path ++ ["."]) where search (p:ps) = do dExists <- doesDirectoryExist p @@ -89,29 +283,7 @@ 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 @@ -135,75 +307,13 @@ 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 <* 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 opts - <*> pAlts opts - <*> pSucceed False - <|> Attr <$> pATTR - <*> pOptClassContext - <*> pNontSet - <*> pAttrs opts - <|> Type <$> pTYPE - <*> pOptClassContext - <*> pIdentifierU - <*> pList pIdentifier - <* pEquals - <*> pComplexType opts - <|> Sem <$> pSEM - <*> pOptClassContext - <*> 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" - 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" - pOptClassContext :: AGParser ClassContext pOptClassContext = pClassContext <* pDoubleArrow @@ -213,30 +323,6 @@ pClassContext = pListSep pComma ((,) <$> pIdentifierU <*> pList pTypeHaskellAnyAsString) -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)") @@ -264,46 +350,16 @@ 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 @@ -314,74 +370,37 @@ 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 <|> Ident "loc" <$> pLOC <|> 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) - <|> (\n e -> [AugmentDef n e]) <$ pAugmentToken <*> pIdentifier <* pAssign <*> pExpr opts - <|> (\n e -> [AroundDef n e]) <$ pAROUND <*> pIdentifier <* pAssign <*> pExpr opts - <|> (\a b -> [AttrOrderBefore a [b]]) <$> pList1 pAttr <* pSmaller <*> pAttr - <|> (\pat owrt exp -> [Def (pat ()) exp owrt]) <$> pPattern (const <$> pAttr) <*> pAssign <*> pExpr opts - pAugmentToken :: AGParser () pAugmentToken = () <$ (pAUGMENT <|> pPlus) 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 :: 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 :: 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" +pAssignPos :: AGParser (Bool, Pos) +pAssignPos = (\p -> (False,p)) <$> pReserved "=" + <|> (\p -> (True,p)) <$> pReserved ":=" + pPattern :: AGParser (a -> (Identifier,Identifier)) -> AGParser (a -> Pattern) pPattern pvar = pPattern2 where pPattern0 = (\i pats a -> Constr i (map ($ a) pats)) @@ -404,13 +423,6 @@ 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, @@ -430,6 +442,7 @@ pTYPE = pCostReserved 90 "TYPE" "TYPE" pINH = pCostReserved 90 "INH" "INH" pSYN = pCostReserved 90 "SYN" "SYN" +pCHN = pCostReserved 90 "CHN" "CHN" pMAYBE = pCostReserved 5 "MAYBE" "MAYBE" pEITHER = pCostReserved 5 "EITHER" "EITHER" pMAP = pCostReserved 5 "MAP" "MAP" diff --git a/src/Scanner.hs b/src/Scanner.hs --- a/src/Scanner.hs +++ b/src/Scanner.hs @@ -132,7 +132,7 @@ keywords = lowercaseKeywords ++ [ "DATA", "EXT", "ATTR", "SEM","TYPE", "USE", "INCLUDE" , "SET","DERIVING","FOR", "WRAPPER", "MAYBE", "EITHER", "MAP", "INTMAP" - , "PRAGMA", "SEMPRAGMA", "MODULE", "ATTACH", "UNIQUEREF", "INH", "SYN" + , "PRAGMA", "SEMPRAGMA", "MODULE", "ATTACH", "UNIQUEREF", "INH", "SYN", "CHN" , "AUGMENT", "AROUND" ] 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.20" +banner = "Attribute Grammar compiler / HUT project. Version 0.9.21" 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.20 +version: 0.9.21 license: GPL license-file: LICENSE maintainer: Arie Middelkoop 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.20 +version: 0.9.21 license: GPL license-file: LICENSE maintainer: Arie Middelkoop