[WIP] Infix constructors

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

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

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

uuagc/trunk/cabal.project

@@ -0,0 +1 @@
+packages: ., cabal-plugin

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] [] []

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)

uuagc/trunk/src-ag/ExecutionPlan2Hs.ag

@@ -1137,13 +1137,15 @@ 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
 
 -- Check if a pattern is just an underscore
 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

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}

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

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

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 ()

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

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
 

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))

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

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

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
@@ -33,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
@@ -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