From b593ae373f4ca12cb1569ca1c80249f47e7f003a Mon Sep 17 00:00:00 2001 From: Jaro Reinders Date: Tue, 16 Jul 2024 18:16:32 +0200 Subject: [PATCH 1/4] Simplify Setup.hs --- uuagc/trunk/Setup.hs | 47 +++++++++-------------------- uuagc/trunk/update-src-generated.sh | 4 +-- uuagc/trunk/uuagc.cabal | 10 +++--- 3 files changed, 22 insertions(+), 39 deletions(-) diff --git a/uuagc/trunk/Setup.hs b/uuagc/trunk/Setup.hs index af085714..70db3865 100644 --- a/uuagc/trunk/Setup.hs +++ b/uuagc/trunk/Setup.hs @@ -1,40 +1,21 @@ --- Note: to bootstrap uuagc with a commandline uuagc, --- pass the -DEXTERNAL_UUAGC to GHC --- when building setup.hs. This can be accomplished using --- cabal install with --ghc-options="-DEXTERNAL_UUAGC". --- --- When this option is used, a cabal flag will be set so --- that the Haskell sources will be regenerated from --- the attribute grammar sources --- --- Note: it would be nicer if this behavior could be enabled --- with a configure flag. However, a compiled Setup.hs is --- required in order to perform 'configure', so configure --- flags are regarded too late in the process. --- Also note that this Setup.hs has conditional package --- requirements depending on what code is used. - {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -{-# LANGUAGE CPP #-} module Main where -#ifdef EXTERNAL_UUAGC import System.Environment (getArgs) -import Distribution.Simple (defaultMainWithHooksArgs) +import Distribution.Simple (defaultMainWithHooksArgs, UserHooks (..), simpleUserHooks) +import Distribution.Simple.LocalBuildInfo (flagAssignment) import Distribution.Simple.UUAGC (uuagcUserHook) +import Distribution.Types.Flag (lookupFlagAssignment, mkFlagName) +import Debug.Trace main :: IO () -main = args >>= defaultMainWithHooksArgs uuagcUserHook - -args :: IO [String] -args = do - as <- getArgs - let addFlags | "configure" `elem` as = ("--flags=bootstrap_external" :) - | otherwise = id - return (addFlags as) -#else -import Distribution.Simple (defaultMain, defaultMainWithHooksArgs) - -main :: IO () -main = defaultMain -#endif +main = do + args <- getArgs + defaultMainWithHooksArgs hooks args + where + hooks = uuagcUserHook { buildHook = myBuildHook } + myBuildHook pd lbi uh bf + | lookupFlagAssignment (mkFlagName "bootstrap_external") (flagAssignment lbi) == Just True + = buildHook uuagcUserHook pd lbi uh bf + | otherwise + = buildHook simpleUserHooks pd lbi uh bf \ No newline at end of file diff --git a/uuagc/trunk/update-src-generated.sh b/uuagc/trunk/update-src-generated.sh index fabcf341..19fb46de 100755 --- a/uuagc/trunk/update-src-generated.sh +++ b/uuagc/trunk/update-src-generated.sh @@ -1,6 +1,6 @@ rm -rf dist-newstyle -cabal v2-configure --ghc-options="-DEXTERNAL_UUAGC" -fwith-loag -cabal v2-build --ghc-options="-DEXTERNAL_UUAGC" +set -e +cabal v2-build -fbootstrap_external -fwith-loag cp dist-newstyle/build/x86_64-linux/ghc-*/uuagc-*/build/*.hs src-generated/ cp dist-newstyle/build/x86_64-linux/ghc-*/uuagc-*/build/LOAG/*.hs src-generated/LOAG/ # Patch the line pragma's a bit diff --git a/uuagc/trunk/uuagc.cabal b/uuagc/trunk/uuagc.cabal index 266aeaae..c863bd94 100644 --- a/uuagc/trunk/uuagc.cabal +++ b/uuagc/trunk/uuagc.cabal @@ -20,8 +20,6 @@ extra-source-files: src-ag/*.ag extra-source-files: src-ag/*.lag extra-source-files: src-ag/LOAG/*.ag --- This flag will be set by Setup.hs, use --- cabal configure --ghc-options="-DEXTERNAL_UUAGC" flag bootstrap_external description: Use an external uuagc executable for bootstrapping default: False @@ -55,8 +53,12 @@ library build-depends: haskell-src-exts >= 1.11.1 build-depends: filepath >= 1.1.0.4 build-depends: aeson >= 1.4.7.1, bytestring >= 0.9.2.1 - hs-source-dirs: src, src-version, src-ag, src-options - if !flag(bootstrap_external) + hs-source-dirs: src, src-version, src-options + if flag(bootstrap_external) + -- we need to avoid any *.ag files if we're not bootstrapping, + -- because we now always use the ag preprocessor. + hs-source-dirs: src-ag + else hs-source-dirs: src-generated exposed-modules: UU.UUAGC, UU.UUAGC.Version default-extensions: TypeSynonymInstances, MultiParamTypeClasses From fb4c6b334897467b5992f8cdb50fe9c936c638a2 Mon Sep 17 00:00:00 2001 From: Jaro Reinders Date: Tue, 16 Jul 2024 19:27:54 +0200 Subject: [PATCH 2/4] Fix LOAG errors --- uuagc/trunk/src/LOAG/Chordal.hs | 8 ++++---- uuagc/trunk/src/LOAG/Optimise.hs | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/uuagc/trunk/src/LOAG/Chordal.hs b/uuagc/trunk/src/LOAG/Chordal.hs index ba23bc05..5e481240 100644 --- a/uuagc/trunk/src/LOAG/Chordal.hs +++ b/uuagc/trunk/src/LOAG/Chordal.hs @@ -133,7 +133,7 @@ scheduleLOAG ag@(Ag nbounds pbounds dps nts) putStrLn opts = do , let pred = varMap M.! (i,s) ] forM dps $ \(f,t) -> do - modifyArray edp t (f `IS.insert`) + LOAG.Common.modifyArray edp t (f `IS.insert`) f_idsf <- freeze idsf f_idst <- freeze idst f_edp <- freeze edp @@ -145,10 +145,10 @@ scheduleLOAG ag@(Ag nbounds pbounds dps nts) putStrLn opts = do -> IOArray Vertex Vertices -> IO [()] addEdges (f,t) es (idsf,idst) edp = do - modifyArray idsf f (t `IS.insert`) - modifyArray idst t (f `IS.insert`) + LOAG.Common.modifyArray idsf f (t `IS.insert`) + LOAG.Common.modifyArray idst t (f `IS.insert`) forM es $ \(f,t) -> do --edp does not reflect flow - modifyArray edp t (f `IS.insert`) + LOAG.Common.modifyArray edp t (f `IS.insert`) noCyclesNt :: Sat -> NtGraph -> IO () noCyclesNt sat g | IM.null g = return () diff --git a/uuagc/trunk/src/LOAG/Optimise.hs b/uuagc/trunk/src/LOAG/Optimise.hs index 17388b6e..0b711158 100644 --- a/uuagc/trunk/src/LOAG/Optimise.hs +++ b/uuagc/trunk/src/LOAG/Optimise.hs @@ -210,8 +210,8 @@ newSchedule sat varMap nbounds tp@(Nt nt _ _ inhs outs _ ) sched = do -> (IOArray Vertex Vertices, IOArray Vertex Vertices) -> IO () addEdges (f,t) (idsf,idst) = do - modifyArray idsf f (t `IS.insert`) - modifyArray idst t (f `IS.insert`) + LOAG.Common.modifyArray idsf f (t `IS.insert`) + LOAG.Common.modifyArray idst t (f `IS.insert`) -- | count the (max, avg, total) number of visits getVisCount :: [Nt] -> InterfaceRes -> VisCount From b8a59018ae40e5c724c970e183d5662e293811f7 Mon Sep 17 00:00:00 2001 From: Jaro Reinders Date: Sat, 27 Sep 2025 17:20:39 +0200 Subject: [PATCH 3/4] Support Cabal 3.12 & 3.14 --- .../src/Distribution/Simple/UUAGC/UUAGC.hs | 26 ++++++++++++++----- uuagc/trunk/cabal-plugin/uuagc-cabal.cabal | 2 +- uuagc/trunk/cabal.project | 1 + uuagc/trunk/uuagc.cabal | 2 +- 4 files changed, 22 insertions(+), 9 deletions(-) create mode 100644 uuagc/trunk/cabal.project diff --git a/uuagc/trunk/cabal-plugin/src/Distribution/Simple/UUAGC/UUAGC.hs b/uuagc/trunk/cabal-plugin/src/Distribution/Simple/UUAGC/UUAGC.hs index 368c54db..f157dcd4 100644 --- a/uuagc/trunk/cabal-plugin/src/Distribution/Simple/UUAGC/UUAGC.hs +++ b/uuagc/trunk/cabal-plugin/src/Distribution/Simple/UUAGC/UUAGC.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, OverloadedStrings, DataKinds #-} module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook, uuagcUserHook', uuagc, @@ -56,7 +56,9 @@ import Data.List (nub,intersperse) import Data.Map (Map) import qualified Data.Map as Map -#if MIN_VERSION_Cabal(3,6,0) +#if MIN_VERSION_Cabal(3,14,0) +import Distribution.Utils.Path (getSymbolicPath, Pkg, Source, SymbolicPath, FileOrDir (Dir), interpretSymbolicPathCWD) +#elif MIN_VERSION_Cabal(3,6,0) import Distribution.Utils.Path (getSymbolicPath, PackageDir, SourceDir, SymbolicPath) #endif @@ -192,6 +194,13 @@ getOptionsFromClass classes fOpt = ++ show fClass ++ " is not defined." +#if MIN_VERSION_Cabal(3,14,0) +buildDir' :: LocalBuildInfo -> FilePath +buildDir' = interpretSymbolicPathCWD . buildDir +#else +buildDir' = buildDir +#endif + -- uuagcSDistHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -- -> PackageDescription -- -> Maybe LocalBuildInfo @@ -202,7 +211,7 @@ getOptionsFromClass classes fOpt = -- {- -- case mbLbi of -- Nothing -> warn normal "sdist: the local buildinfo was not present. Skipping AG initialization. Dist may fail." --- Just lbi -> let classesPath = buildDir lbi agClassesFile +-- Just lbi -> let classesPath = buildDir' lbi agClassesFile -- in commonHook uuagc classesPath pd lbi (sDistVerbosity df) -- originalSDistHook pd mbLbi uh df -- -} @@ -216,7 +225,7 @@ uuagcBuildHook -> BuildFlags -> IO () uuagcBuildHook uuagc pd lbi uh bf = do - let classesPath = buildDir lbi agClassesFile + let classesPath = buildDir' lbi agClassesFile commonHook uuagc classesPath pd lbi (buildVerbosity bf) originalBuildHook pd lbi uh bf @@ -229,7 +238,7 @@ commonHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) commonHook uuagc classesPath pd lbi fl = do let verbosity = fromFlagOrDefault normal fl info verbosity $ "commonHook: Assuming AG classesPath: " ++ classesPath - createDirectoryIfMissingVerbose verbosity True (buildDir lbi) + createDirectoryIfMissingVerbose verbosity True (buildDir' lbi) -- Read already existing options -- Map FilePath (Options, Maybe (FilePath,[String])) oldOptions <- readFileOptions classesPath @@ -272,7 +281,7 @@ uuagc' uuagc build lbi _ = platformIndependent = True, runPreProcessor = mkSimplePreProcessor $ \ inFile outFile verbosity -> do notice verbosity $ "[UUAGC] processing: " ++ inFile ++ " generating: " ++ outFile - let classesPath = buildDir lbi agClassesFile + let classesPath = buildDir' lbi agClassesFile info verbosity $ "uuagc-preprocessor: Assuming AG classesPath: " ++ classesPath fileOpts <- readFileOptions classesPath opts <- case Map.lookup inFile fileOpts of @@ -290,7 +299,10 @@ uuagc' uuagc build lbi _ = -- | In Cabal 3.6.0.0 (GHC 9.2) and up, 'BuildInfo' member 'hsSourceDirs' has type -- '[SymbolicPath PackageDir SourceDir]', but in versions before that, it is [FilePath]. -#if MIN_VERSION_Cabal(3,6,0) +#if MIN_VERSION_Cabal(3,14,0) +hsSourceDirsFilePaths :: [SymbolicPath Pkg (Dir Source)] -> [FilePath] +hsSourceDirsFilePaths = map getSymbolicPath +#elif MIN_VERSION_Cabal(3,6,0) hsSourceDirsFilePaths :: [SymbolicPath PackageDir SourceDir] -> [FilePath] hsSourceDirsFilePaths = map getSymbolicPath #else diff --git a/uuagc/trunk/cabal-plugin/uuagc-cabal.cabal b/uuagc/trunk/cabal-plugin/uuagc-cabal.cabal index f285eaa4..13301ec4 100644 --- a/uuagc/trunk/cabal-plugin/uuagc-cabal.cabal +++ b/uuagc/trunk/cabal-plugin/uuagc-cabal.cabal @@ -17,7 +17,7 @@ tested-with: GHC >= 6.12 extra-source-files: README library - build-depends: base >= 4, base < 5, Cabal >= 2, directory >= 1.0.1.1 + build-depends: base >= 4, base < 5, Cabal >= 2.0 && <3.15, directory >= 1.0.1.1 build-depends: process >= 1.0.1.3, containers >= 0.3, uulib >= 0.9.14, filepath >= 1.1.0.4, mtl >= 2.2.1 hs-source-dirs: src, src-options default-language: Haskell2010 diff --git a/uuagc/trunk/cabal.project b/uuagc/trunk/cabal.project new file mode 100644 index 00000000..64ec5e97 --- /dev/null +++ b/uuagc/trunk/cabal.project @@ -0,0 +1 @@ +packages: ., cabal-plugin \ No newline at end of file diff --git a/uuagc/trunk/uuagc.cabal b/uuagc/trunk/uuagc.cabal index c863bd94..377672c9 100644 --- a/uuagc/trunk/uuagc.cabal +++ b/uuagc/trunk/uuagc.cabal @@ -31,7 +31,7 @@ flag with-loag manual: True custom-setup - setup-depends: base >= 4 && < 5, Cabal >= 1.24 && < 3.11, uuagc-cabal >= 1.0 + setup-depends: base >= 4 && < 5, Cabal >= 2.0 && < 3.15, uuagc-cabal >= 1.0 executable uuagc build-depends: uuagc-cabal >= 1.0.3.0 From 79139d41c7d1252c4c1497aa34b754ad9e8c5f54 Mon Sep 17 00:00:00 2001 From: Jaro Reinders Date: Wed, 17 Jul 2024 20:10:53 +0200 Subject: [PATCH 4/4] Start working on infix constructor patterns --- uuagc/trunk/src-ag/AbstractSyntaxDump.ag | 1 + uuagc/trunk/src-ag/DefaultRules.ag | 2 ++ uuagc/trunk/src-ag/ExecutionPlan2Hs.ag | 6 ++++-- uuagc/trunk/src-ag/Patterns.ag | 3 +++ uuagc/trunk/src-ag/PrintCode.ag | 7 +++++-- uuagc/trunk/src-ag/Transform.ag | 2 ++ uuagc/trunk/src/PPUtil.hs | 3 +++ uuagc/trunk/src/Parser.hs | 3 ++- uuagc/trunk/src/Scanner.hs | 3 +++ 9 files changed, 25 insertions(+), 5 deletions(-) diff --git a/uuagc/trunk/src-ag/AbstractSyntaxDump.ag b/uuagc/trunk/src-ag/AbstractSyntaxDump.ag index 05978839..0df4d6df 100644 --- a/uuagc/trunk/src-ag/AbstractSyntaxDump.ag +++ b/uuagc/trunk/src-ag/AbstractSyntaxDump.ag @@ -42,6 +42,7 @@ SEM TypeSig SEM Pattern | Constr lhs . pp = ppNestInfo ["Pattern","Constr"] [pp @name] [ppF "pats" $ ppVList @pats.ppL] [] + | InfixConstr lhs . pp = ppNestInfo ["Pattern","InfixConstr"] [pp @name] [ppF "patl" @patl.pp, ppF "patr" @patr.pp] [] | Product lhs . pp = ppNestInfo ["Pattern","Product"] [ppShow @pos] [ppF "pats" $ ppVList @pats.ppL] [] | Alias lhs . pp = ppNestInfo ["Pattern","Alias"] [pp @field, pp @attr] [ppF "pat" $ @pat.pp] [] | Underscore lhs . pp = ppNestInfo ["Pattern","Underscore"] [ppShow @pos] [] [] diff --git a/uuagc/trunk/src-ag/DefaultRules.ag b/uuagc/trunk/src-ag/DefaultRules.ag index 7c7e76c3..6a2a423c 100644 --- a/uuagc/trunk/src-ag/DefaultRules.ag +++ b/uuagc/trunk/src-ag/DefaultRules.ag @@ -508,12 +508,14 @@ addAugments (syn, exprs) rules modify r = r containsSyn (Constr _ pats) = any containsSyn pats + containsSyn (InfixConstr _ patl patr) = containsSyn patl || containsSyn patr containsSyn (Product _ pats) = any containsSyn pats containsSyn (Irrefutable pat) = containsSyn pat containsSyn (Alias field attr pat) = (field == _LHS && attr == syn) || containsSyn pat containsSyn _ = False modifyPat (Constr name pats) = Constr name (map modifyPat pats) + modifyPat (InfixConstr name patl patr) = InfixConstr name (modifyPat patl) (modifyPat patr) modifyPat (Product pos pats) = Product pos (map modifyPat pats) modifyPat (Irrefutable pat) = Irrefutable (modifyPat pat) modifyPat (Alias field attr pat) diff --git a/uuagc/trunk/src-ag/ExecutionPlan2Hs.ag b/uuagc/trunk/src-ag/ExecutionPlan2Hs.ag index 3092dbe7..c54ca2a3 100644 --- a/uuagc/trunk/src-ag/ExecutionPlan2Hs.ag +++ b/uuagc/trunk/src-ag/ExecutionPlan2Hs.ag @@ -1137,6 +1137,7 @@ SEM Pattern lhs.sem_lhs = @loc.addbang1 @loc.patExpr | Product lhs.sem_lhs = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs | Constr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs + | InfixConstr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @patl.sem_lhs >#< @name >#< @patr.sem_lhs | Underscore lhs.sem_lhs = text "_" | Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs @@ -1144,6 +1145,7 @@ SEM Pattern ATTR Pattern [ | | isUnderscore:{Bool}] SEM Pattern | Constr lhs.isUnderscore = False + | InfixConstr lhs.isUnderscore = False | Product lhs.isUnderscore = False | Alias lhs.isUnderscore = False | Underscore lhs.isUnderscore = True @@ -1553,12 +1555,12 @@ SEM EProduction | EProduction loc.addbang = \x -> if bangpats @lhs.options SEM EChild | EChild loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x SEM EChild | ETerm loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x SEM VisitStep | ChildVisit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x -SEM Pattern | Alias Constr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x +SEM Pattern | Alias Constr InfixConstr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x SEM Visit | Visit loc.addbang1 = if isLazyKind @kind then id else @loc.addbang SEM ENonterminal | ENonterminal loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id SEM ERule | ERule loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang -SEM Pattern | Alias Constr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang +SEM Pattern | Alias Constr InfixConstr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang -- -- Distribute single-visit-next map downward diff --git a/uuagc/trunk/src-ag/Patterns.ag b/uuagc/trunk/src-ag/Patterns.ag index 0a5a803d..cef3f135 100644 --- a/uuagc/trunk/src-ag/Patterns.ag +++ b/uuagc/trunk/src-ag/Patterns.ag @@ -9,6 +9,9 @@ TYPE Patterns = [Pattern] DATA Pattern | Constr name : {ConstructorIdent} pats : Patterns + | InfixConstr name : {ConstructorIdent} + patl : Pattern + patr : Pattern | Product pos : {Pos} pats : Patterns | Alias field : {Identifier} diff --git a/uuagc/trunk/src-ag/PrintCode.ag b/uuagc/trunk/src-ag/PrintCode.ag index 2a8e71f1..fca50737 100644 --- a/uuagc/trunk/src-ag/PrintCode.ag +++ b/uuagc/trunk/src-ag/PrintCode.ag @@ -353,13 +353,14 @@ SEM Patterns [ | | pps : {[PP_Doc]} ] | Nil lhs.pps = [] SEM Pattern - | Constr Product Alias + | Constr InfixConstr Product Alias loc.addBang = if bangpats @lhs.options && not @lhs.isDeclOfLet && not @lhs.belowIrrefutable then \p -> "!" >|< p else id SEM Pattern [ | | pp:PP_Doc ] - | Constr lhs.pp = @loc.addBang $ pp_parens $ @name >#< hv_sp @pats.pps + | Constr lhs.pp = @loc.addBang $ pp_parens $ @pats.pps >#< @name >#< @pats.pps + | InfixConstr lhs.pp = @loc.addBang $ pp_parens $ @patl.pp >#< @name >#< @patr.pp | Product lhs.pp = @loc.addBang $ pp_block "(" ")" "," @pats.pps | Alias loc.ppVar = pp (attrname @lhs.options False @field @attr) loc.ppVarBang = @loc.addBang $ @loc.ppVar @@ -371,6 +372,7 @@ SEM Pattern [ | | pp:PP_Doc ] SEM Pattern [ | | isUnderscore:{Bool}] | Constr lhs.isUnderscore = False + | InfixConstr lhs.isUnderscore = False | Product lhs.isUnderscore = False | Alias lhs.isUnderscore = False | Underscore lhs.isUnderscore = True @@ -394,6 +396,7 @@ SEM Patterns [ | | pps' : {[PP_Doc]} ] SEM Pattern [ | | pp':PP_Doc ] | Constr lhs.pp' = pp_parens $ @name >#< hv_sp (map pp_parens @pats.pps') + | InfixConstr lhs.pp' = pp_parens $ pp_parens @patl.pp' >#< @name >#< pp_parens @patr.pp' | Product lhs.pp' = pp_block "(" ")" "," @pats.pps' | Alias lhs.pp' = let attribute | @field == _LOC || @field == nullIdent = locname' @attr | otherwise = attrname @lhs.options False @field @attr diff --git a/uuagc/trunk/src-ag/Transform.ag b/uuagc/trunk/src-ag/Transform.ag index ac69bfa8..718a8c5e 100644 --- a/uuagc/trunk/src-ag/Transform.ag +++ b/uuagc/trunk/src-ag/Transform.ag @@ -1188,6 +1188,7 @@ SEM Pattern lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts | Underscore lhs.patunder = \_ -> @copy | Constr lhs.patunder = \us -> Constr @name (@pats.patunder us) + | InfixConstr lhs.patunder = \us -> InfixConstr @name (@patl.patunder us) (@patr.patunder us) | Product lhs.patunder = \us -> Product @pos (@pats.patunder us) | Irrefutable lhs.patunder = \us -> Irrefutable (@pat.patunder us) @@ -1199,6 +1200,7 @@ ATTR Pattern [ | | stpos : Pos ] SEM Pattern | Constr lhs.stpos = getPos @name + | InfixConstr lhs.stpos = @patl.stpos | Product lhs.stpos = @pos | Alias lhs.stpos = getPos @field | Underscore lhs.stpos = @pos diff --git a/uuagc/trunk/src/PPUtil.hs b/uuagc/trunk/src/PPUtil.hs index 35e5f8dd..7c27f13f 100644 --- a/uuagc/trunk/src/PPUtil.hs +++ b/uuagc/trunk/src/PPUtil.hs @@ -43,6 +43,9 @@ ppNestInfo {- opts -} nms attrs ps infos ) >-< indent 2 (vlist ps) +-- >>> ppNestInfo ["foo"] [text "bar"] [] [] +-- Data constructor not in scope: Str :: String -> PP_Doc + ppNm :: String -> PP_Doc ppNm = text . show diff --git a/uuagc/trunk/src/Parser.hs b/uuagc/trunk/src/Parser.hs index c005a003..27d67110 100644 --- a/uuagc/trunk/src/Parser.hs +++ b/uuagc/trunk/src/Parser.hs @@ -530,7 +530,8 @@ 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 "a pattern") + <|> pChainr ((\(x,p) l r a -> InfixConstr (Ident x p) (l a) (r a)) <$> (pConsymPos <|> ((\x -> (":",x)) <$> pReserved ":"))) pPattern1 pPattern1 = pvariable <|> pPattern2 pvariable = (\ir var pat a -> case var a of (fld,att) -> ir $ Alias fld att (pat a)) diff --git a/uuagc/trunk/src/Scanner.hs b/uuagc/trunk/src/Scanner.hs index 50e00a3c..b8f3dd73 100644 --- a/uuagc/trunk/src/Scanner.hs +++ b/uuagc/trunk/src/Scanner.hs @@ -118,6 +118,9 @@ scan opts p0 tok | str `elem` keywords' = reserved (mkKeyword str) | otherwise = valueToken TkConid str in (tok p, advc (length var+1) p,rest) + -- FIXME: this does not work because : is reserved... + | x == ':' = let (var,rest) = span (`elem` "!#$%&⋆+./<=>?@\\^|-~:") rs + in (valueToken TkConOp (':' : var) p, advc (length var+1) p,rest) | otherwise = (errToken ("unexpected character " ++ show x) p, advc 1 p, rs) scanBeginOfLine :: Lexer Token