From 1ba5449d210b2b5565e1a3179548cfb2df9fce1b Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Thu, 24 Jun 2021 09:31:37 +0200 Subject: Update pgf.cabal, and minors to other cabal files --- src/runtime/haskell-bind/pgf2.cabal | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'src/runtime/haskell-bind') diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal index 91e77c77b..c8d5d8c6c 100644 --- a/src/runtime/haskell-bind/pgf2.cabal +++ b/src/runtime/haskell-bind/pgf2.cabal @@ -9,8 +9,7 @@ homepage: https://www.grammaticalframework.org license: LGPL-3 license-file: LICENSE author: Krasimir Angelov -maintainer: kr.angelov@gmail.com -category: Language +category: Natural Language Processing build-type: Simple extra-source-files: CHANGELOG.md, README.md cabal-version: >=1.10 -- cgit v1.2.3 From e1a40640cd55b6047f2aa36bf3394017d8867fd6 Mon Sep 17 00:00:00 2001 From: 2jacobtan Date: Tue, 6 Jul 2021 05:42:34 +0800 Subject: specify version bounds in pgf.cabal and pgf2.cabal --- src/runtime/haskell-bind/pgf2.cabal | 6 +++--- src/runtime/haskell/pgf.cabal | 18 +++++++++--------- 2 files changed, 12 insertions(+), 12 deletions(-) (limited to 'src/runtime/haskell-bind') diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal index c8d5d8c6c..fcd854d72 100644 --- a/src/runtime/haskell-bind/pgf2.cabal +++ b/src/runtime/haskell-bind/pgf2.cabal @@ -23,9 +23,9 @@ library PGF2.Expr, PGF2.Type build-depends: - base >=4.3 && <5, - containers, - pretty + base >= 4.9.1 && <4.15, + containers >= 0.5.7 && < 0.7, + pretty >= 1.1.3 && < 1.2 default-language: Haskell2010 build-tools: hsc2hs extra-libraries: pgf gu diff --git a/src/runtime/haskell/pgf.cabal b/src/runtime/haskell/pgf.cabal index f829a6e35..9a59502c4 100644 --- a/src/runtime/haskell/pgf.cabal +++ b/src/runtime/haskell/pgf.cabal @@ -14,16 +14,16 @@ tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2, GHC==8.4.4 library default-language: Haskell2010 build-depends: - array, - base >= 4.6 && <5, - bytestring, - containers, + base >= 4.9.1 && <4.15, + array >= 0.5.1 && < 0.6, + containers >= 0.5.7 && < 0.7, + bytestring >= 0.10.8 && < 0.11, + utf8-string >= 1.0.1.1 && < 1.1, + random >= 1.1 && < 1.3, + pretty >= 1.1.3 && < 1.2, + mtl >= 2.2.1 && < 2.3, + ghc-prim >= 0.5.0 && < 0.7 -- exceptions, - ghc-prim, - mtl, - pretty, - random, - utf8-string other-modules: -- not really part of GF but I have changed the original binary library -- cgit v1.2.3 From 84b4b6fab93a2ef9367878a6055595f81552791d Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Tue, 6 Jul 2021 14:11:30 +0200 Subject: Some more cabal file cleanup. Add stack files for pgf, pgf2. --- gf.cabal | 9 ++++----- src/runtime/haskell-bind/pgf2.cabal | 15 +++++++++------ src/runtime/haskell-bind/stack-ghc7.10.3.yaml | 3 +++ src/runtime/haskell-bind/stack-ghc8.0.2.yaml | 1 + src/runtime/haskell-bind/stack-ghc8.10.4.yaml | 1 + src/runtime/haskell/pgf.cabal | 13 +++++++------ src/runtime/haskell/stack-ghc7.10.3.yaml | 3 +++ src/runtime/haskell/stack-ghc8.0.2.yaml | 1 + src/runtime/haskell/stack-ghc8.10.4.yaml | 1 + 9 files changed, 30 insertions(+), 17 deletions(-) create mode 100644 src/runtime/haskell-bind/stack-ghc7.10.3.yaml create mode 100644 src/runtime/haskell-bind/stack-ghc8.0.2.yaml create mode 100644 src/runtime/haskell-bind/stack-ghc8.10.4.yaml create mode 100644 src/runtime/haskell/stack-ghc7.10.3.yaml create mode 100644 src/runtime/haskell/stack-ghc8.0.2.yaml create mode 100644 src/runtime/haskell/stack-ghc8.10.4.yaml (limited to 'src/runtime/haskell-bind') diff --git a/gf.cabal b/gf.cabal index 0eba0ead3..b9c7d9631 100644 --- a/gf.cabal +++ b/gf.cabal @@ -8,10 +8,9 @@ license-file: LICENSE category: Natural Language Processing, Compiler synopsis: Grammatical Framework description: GF, Grammatical Framework, is a programming language for multilingual grammar applications -homepage: http://www.grammaticalframework.org/ +homepage: https://www.grammaticalframework.org/ bug-reports: https://github.com/GrammaticalFramework/gf-core/issues -maintainer: Thomas Hallgren -tested-with: GHC==8.0.2, GHC==8.10.4 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4 data-dir: src extra-source-files: WebSetup.hs @@ -75,7 +74,7 @@ flag c-runtime library default-language: Haskell2010 build-depends: - -- | GHC 8.0.2 to GHC 8.10.4 + -- GHC 8.0.2 to GHC 8.10.4 base >= 4.9.1 && <4.15, array >= 0.5.1 && < 0.6, containers >= 0.5.7 && < 0.7, @@ -84,9 +83,9 @@ library random >= 1.1 && < 1.3, pretty >= 1.1.3 && < 1.2, mtl >= 2.2.1 && < 2.3, + -- For compatability with GHC < 8 exceptions >= 0.8.3 && < 0.11, fail >= 4.9.0 && < 4.10, - -- For compatability with ghc < 8 -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant. transformers-compat >= 0.5.1.4 && < 0.7, ghc-prim >= 0.5.0 && < 0.7 diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal index fcd854d72..eb1e3c708 100644 --- a/src/runtime/haskell-bind/pgf2.cabal +++ b/src/runtime/haskell-bind/pgf2.cabal @@ -1,18 +1,21 @@ name: pgf2 version: 1.3.0 + +cabal-version: 1.22 +build-type: Simple +license: LGPL-3 +license-file: LICENSE +category: Natural Language Processing synopsis: Bindings to the C version of the PGF runtime description: GF, Grammatical Framework, is a programming language for multilingual grammar applications. GF grammars are compiled into Portable Grammar Format (PGF) which can be used with the PGF runtime, written in C. This package provides Haskell bindings to that runtime. -homepage: https://www.grammaticalframework.org -license: LGPL-3 -license-file: LICENSE +homepage: https://www.grammaticalframework.org/ +bug-reports: https://github.com/GrammaticalFramework/gf-core/issues author: Krasimir Angelov -category: Natural Language Processing -build-type: Simple extra-source-files: CHANGELOG.md, README.md -cabal-version: >=1.10 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4 library exposed-modules: diff --git a/src/runtime/haskell-bind/stack-ghc7.10.3.yaml b/src/runtime/haskell-bind/stack-ghc7.10.3.yaml new file mode 100644 index 000000000..c916b4bb0 --- /dev/null +++ b/src/runtime/haskell-bind/stack-ghc7.10.3.yaml @@ -0,0 +1,3 @@ +resolver: lts-6.35 # ghc 7.10.3 + +allow-newer: true diff --git a/src/runtime/haskell-bind/stack-ghc8.0.2.yaml b/src/runtime/haskell-bind/stack-ghc8.0.2.yaml new file mode 100644 index 000000000..af08206d9 --- /dev/null +++ b/src/runtime/haskell-bind/stack-ghc8.0.2.yaml @@ -0,0 +1 @@ +resolver: lts-9.21 # ghc 8.0.2 diff --git a/src/runtime/haskell-bind/stack-ghc8.10.4.yaml b/src/runtime/haskell-bind/stack-ghc8.10.4.yaml new file mode 100644 index 000000000..195e90993 --- /dev/null +++ b/src/runtime/haskell-bind/stack-ghc8.10.4.yaml @@ -0,0 +1 @@ +resolver: lts-18.0 # ghc 8.10.4 diff --git a/src/runtime/haskell/pgf.cabal b/src/runtime/haskell/pgf.cabal index 9a59502c4..56c1ca04a 100644 --- a/src/runtime/haskell/pgf.cabal +++ b/src/runtime/haskell/pgf.cabal @@ -1,15 +1,15 @@ name: pgf -version: 3.10.1-git +version: 3.11.0-git -cabal-version: >= 1.20 +cabal-version: 1.22 build-type: Simple license: OtherLicense category: Natural Language Processing synopsis: Grammatical Framework description: A library for interpreting the Portable Grammar Format (PGF) -homepage: http://www.grammaticalframework.org/ +homepage: https://www.grammaticalframework.org/ bug-reports: https://github.com/GrammaticalFramework/gf-core/issues -tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2, GHC==8.4.4 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4 library default-language: Haskell2010 @@ -22,8 +22,9 @@ library random >= 1.1 && < 1.3, pretty >= 1.1.3 && < 1.2, mtl >= 2.2.1 && < 2.3, - ghc-prim >= 0.5.0 && < 0.7 - -- exceptions, + ghc-prim >= 0.5.0 && < 0.7, + -- For compatability with GHC < 8 + fail >= 4.9.0 && < 4.10 other-modules: -- not really part of GF but I have changed the original binary library diff --git a/src/runtime/haskell/stack-ghc7.10.3.yaml b/src/runtime/haskell/stack-ghc7.10.3.yaml new file mode 100644 index 000000000..c916b4bb0 --- /dev/null +++ b/src/runtime/haskell/stack-ghc7.10.3.yaml @@ -0,0 +1,3 @@ +resolver: lts-6.35 # ghc 7.10.3 + +allow-newer: true diff --git a/src/runtime/haskell/stack-ghc8.0.2.yaml b/src/runtime/haskell/stack-ghc8.0.2.yaml new file mode 100644 index 000000000..af08206d9 --- /dev/null +++ b/src/runtime/haskell/stack-ghc8.0.2.yaml @@ -0,0 +1 @@ +resolver: lts-9.21 # ghc 8.0.2 diff --git a/src/runtime/haskell/stack-ghc8.10.4.yaml b/src/runtime/haskell/stack-ghc8.10.4.yaml new file mode 100644 index 000000000..195e90993 --- /dev/null +++ b/src/runtime/haskell/stack-ghc8.10.4.yaml @@ -0,0 +1 @@ +resolver: lts-18.0 # ghc 8.10.4 -- cgit v1.2.3 From 0c3ca3d79acb34e0159cf6b51ba41ff570ad2af1 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Tue, 6 Jul 2021 14:43:21 +0200 Subject: Add note in PGF2 documentation about risk for integer overflow. Closes #109 --- src/runtime/haskell-bind/PGF2/Expr.hsc | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) (limited to 'src/runtime/haskell-bind') diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc index 85e55ab40..35ee628d1 100644 --- a/src/runtime/haskell-bind/PGF2/Expr.hsc +++ b/src/runtime/haskell-bind/PGF2/Expr.hsc @@ -19,7 +19,7 @@ wildCId = "_" :: CId type Cat = CId -- ^ Name of syntactic category type Fun = CId -- ^ Name of function -data BindType = +data BindType = Explicit | Implicit deriving Show @@ -38,7 +38,7 @@ instance Show Expr where show = showExpr [] instance Eq Expr where - (Expr e1 e1_touch) == (Expr e2 e2_touch) = + (Expr e1 e1_touch) == (Expr e2 e2_touch) = unsafePerformIO $ do res <- pgf_expr_eq e1 e2 e1_touch >> e2_touch @@ -113,9 +113,9 @@ unApp (Expr expr touch) = appl <- pgf_expr_unapply expr pl if appl == nullPtr then return Nothing - else do + else do fun <- peekCString =<< (#peek PgfApplication, fun) appl - arity <- (#peek PgfApplication, n_args) appl :: IO CInt + arity <- (#peek PgfApplication, n_args) appl :: IO CInt c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args)) return $ Just (fun, [Expr c_arg touch | c_arg <- c_args]) @@ -140,7 +140,9 @@ unStr (Expr expr touch) = touch return (Just s) --- | Constructs an expression from an integer literal +-- | Constructs an expression from an integer literal. +-- Note that the C runtime does not support long integers, and you may run into overflow issues with large values. +-- See [here](https://github.com/GrammaticalFramework/gf-core/issues/109) for more details. mkInt :: Int -> Expr mkInt val = unsafePerformIO $ do @@ -267,7 +269,7 @@ foreign import ccall "wrapper" -- in the expression in order reverse to the order -- of binding. showExpr :: [CId] -> Expr -> String -showExpr scope e = +showExpr scope e = unsafePerformIO $ withGuPool $ \tmpPl -> do (sb,out) <- newOut tmpPl -- cgit v1.2.3 From f2e52d6f2c2bc90febceebdea0268b40ea37476c Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 7 Jul 2021 09:40:41 +0200 Subject: Replace tabs for whitespace in source code --- src/compiler/GF/Compile/CFGtoPGF.hs | 12 +- src/compiler/GF/Compile/CheckGrammar.hs | 4 +- src/compiler/GF/Compile/Rename.hs | 26 +- src/compiler/GF/Compile/TypeCheck/Abstract.hs | 16 +- src/compiler/GF/Compile/TypeCheck/Concrete.hs | 1 - src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs | 16 +- src/compiler/GF/Compile/TypeCheck/TC.hs | 88 +-- src/compiler/GF/Compile/Update.hs | 66 +- src/compiler/GF/Data/BacktrackM.hs | 26 +- src/compiler/GF/Data/Graph.hs | 20 +- src/compiler/GF/Data/Graphviz.hs | 28 +- src/compiler/GF/Data/Operations.hs | 74 +-- src/compiler/GF/Data/Relation.hs | 18 +- src/compiler/GF/Data/Utilities.hs | 10 +- src/compiler/GF/Grammar/Canonical.hs | 22 +- src/compiler/GF/Grammar/Lexer.x | 2 +- src/compiler/GF/Grammar/Lookup.hs | 26 +- src/compiler/GF/Grammar/PatternMatch.hs | 33 +- src/compiler/GF/Grammar/Printer.hs | 729 +++++++++++------------ src/compiler/GF/Grammar/Values.hs | 19 +- src/compiler/GF/Infra/CheckM.hs | 12 +- src/compiler/GF/Interactive.hs | 2 +- src/compiler/GF/Speech/FiniteState.hs | 110 ++-- src/compiler/GF/Speech/GSL.hs | 6 +- src/compiler/GF/Speech/JSGF.hs | 7 +- src/compiler/GF/Speech/PGFToCFG.hs | 16 +- src/compiler/GF/Speech/SRG.hs | 50 +- src/compiler/GF/Speech/SRGS_ABNF.hs | 11 +- src/compiler/GF/Speech/SRGS_XML.hs | 24 +- src/compiler/GF/Text/Transliterations.hs | 132 ++-- src/runtime/haskell-bind/pgf2.cabal | 2 +- src/runtime/haskell/pgf.cabal | 2 +- 32 files changed, 803 insertions(+), 807 deletions(-) (limited to 'src/runtime/haskell-bind') diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs index f9ab8afcf..59448ce97 100644 --- a/src/compiler/GF/Compile/CFGtoPGF.hs +++ b/src/compiler/GF/Compile/CFGtoPGF.hs @@ -18,7 +18,7 @@ import Data.List -------------------------- cf2pgf :: FilePath -> ParamCFG -> PGF -cf2pgf fpath cf = +cf2pgf fpath cf = let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf)) in updateProductionIndices pgf where @@ -33,7 +33,7 @@ cf2abstr cfg = Abstr aflags afuns acats acats = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0)) | (cat,rules) <- (Map.toList . Map.fromListWith (++)) - [(cat2id cat, catRules cfg cat) | + [(cat2id cat, catRules cfg cat) | cat <- allCats' cfg]] afuns = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0)) | rule <- allRules cfg] @@ -52,7 +52,7 @@ cf2concr cfg = Concr Map.empty Map.empty cats = allCats' cfg rules = allRules cfg - sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] : + sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] : map mkSequence rules) sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0) @@ -102,7 +102,7 @@ cf2concr cfg = Concr Map.empty Map.empty mkLinDefRef (cat,_) = (cat2fid cat 0,[0]) - + addProd prods (fid,prod) = case IntMap.lookup fid prods of Just set -> IntMap.insert fid (Set.insert prod set) prods @@ -130,5 +130,5 @@ cf2concr cfg = Concr Map.empty Map.empty mkRuleName rule = case ruleName rule of - CFObj n _ -> n - _ -> wildCId + CFObj n _ -> n + _ -> wildCId diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 71bce96c4..7f053f85c 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -175,7 +175,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do checkTyp gr typ case md of Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $ - checkDef gr (m,c) typ eq) eqs + checkDef gr (m,c) typ eq) eqs Nothing -> return () return (AbsFun (Just (L loc typ)) ma md moper) @@ -316,7 +316,7 @@ linTypeOfType cnc m typ = do mkLinArg (i,(n,mc@(m,cat))) = do val <- lookLin mc let vars = mkRecType varLabel $ replicate n typeStr - symb = argIdent n cat i + symb = argIdent n cat i rec <- if n==0 then return val else errIn (render ("extending" $$ nest 2 vars $$ diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index c7ea56b45..41b2cdc67 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/05/30 18:39:44 $ +-- > CVS $Date: 2005/05/30 18:39:44 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.19 $ -- @@ -23,9 +23,9 @@ ----------------------------------------------------------------------------- module GF.Compile.Rename ( - renameSourceTerm, - renameModule - ) where + renameSourceTerm, + renameModule + ) where import GF.Infra.Ident import GF.Infra.CheckM @@ -68,7 +68,7 @@ renameIdentTerm env = accumulateError (renameIdentTerm' env) -- Fails immediately on error, makes it possible to try other possibilities renameIdentTerm' :: Status -> Term -> Check Term -renameIdentTerm' env@(act,imps) t0 = +renameIdentTerm' env@(act,imps) t0 = case t0 of Vr c -> ident predefAbs c Cn c -> ident (\_ s -> checkError s) c @@ -85,8 +85,8 @@ renameIdentTerm' env@(act,imps) t0 = _ -> return t0 where opens = [st | (OSimple _,st) <- imps] - qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ - [(m, st) | (OQualif _ m, st) <- imps] ++ + qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ + [(m, st) | (OQualif _ m, st) <- imps] ++ [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible -- this facility is mainly for BWC with GF1: you need not import PredefAbs @@ -94,7 +94,7 @@ renameIdentTerm' env@(act,imps) t0 = | isPredefCat c = return (Q (cPredefAbs,c)) | otherwise = checkError s - ident alt c = + ident alt c = case Map.lookup c act of Just f -> return (f c) _ -> case mapMaybe (Map.lookup c) opens of @@ -157,7 +157,7 @@ modInfo2status (o,mo) = (o,tree2status o (jments mo)) self2status :: ModuleName -> ModuleInfo -> StatusMap self2status c m = Map.mapWithKey (info2status (Just c)) (jments m) - + renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info renameInfo cwd status (m,mi) i info = case info of @@ -208,7 +208,7 @@ renameTerm env vars = ren vars where Abs b x t -> liftM (Abs b x) (ren (x:vs) t) Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b) Typed a b -> liftM2 Typed (ren vs a) (ren vs b) - Vr x + Vr x | elem x vs -> return trm | otherwise -> renid trm Cn _ -> renid trm @@ -219,7 +219,7 @@ renameTerm env vars = ren vars where i' <- case i of TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source _ -> return i - liftM (T i') $ mapM (renCase vs) cs + liftM (T i') $ mapM (renCase vs) cs Let (x,(m,a)) b -> do m' <- case m of @@ -229,7 +229,7 @@ renameTerm env vars = ren vars where b' <- ren (x:vs) b return $ Let (x,(m',a')) b' - P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either + P t@(Vr r) l -- Here we have $r.l$ and this is ambiguous it could be either -- record projection from variable or constant $r$ or qualified expression with module $r$ | elem r vs -> return trm -- try var proj first .. | otherwise -> checks [ renid' (Q (MN r,label2ident l)) -- .. and qualified expression second. @@ -331,7 +331,7 @@ renamePattern env patt = renameContext :: Status -> Context -> Check Context renameContext b = renc [] where renc vs cont = case cont of - (bt,x,t) : xts + (bt,x,t) : xts | isWildIdent x -> do t' <- ren vs t xts' <- renc vs xts diff --git a/src/compiler/GF/Compile/TypeCheck/Abstract.hs b/src/compiler/GF/Compile/TypeCheck/Abstract.hs index 196e1a646..c76660259 100644 --- a/src/compiler/GF/Compile/TypeCheck/Abstract.hs +++ b/src/compiler/GF/Compile/TypeCheck/Abstract.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/15 16:22:02 $ +-- > CVS $Date: 2005/09/15 16:22:02 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.16 $ -- @@ -13,11 +13,11 @@ ----------------------------------------------------------------------------- module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly. - checkContext, - checkTyp, - checkDef, - checkConstrs, - ) where + checkContext, + checkTyp, + checkDef, + checkConstrs, + ) where import GF.Data.Operations @@ -33,8 +33,8 @@ import GF.Text.Pretty --import Control.Monad (foldM, liftM, liftM2) -- | invariant way of creating TCEnv from context -initTCEnv gamma = - (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) +initTCEnv gamma = + (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) -- interface to TC type checker diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs index 380970405..e9420290a 100644 --- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs +++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs @@ -69,7 +69,6 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t lockRecType c t' ---- locking to be removed AR 20/6/2009 _ | ty == typeTok -> return typeStr - _ | isPredefConstant ty -> return ty _ -> composOp (comp g) ty diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index c32afa7a5..d85af5361 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs @@ -396,7 +396,7 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do return ((l,ty):rs,mb_ty) -- | Invariant: if the third argument is (Just rho), --- then rho is in weak-prenex form +-- then rho is in weak-prenex form instSigma :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho) instSigma ge scope t ty1 Nothing = return (t,ty1) -- INST1 instSigma ge scope t ty1 (Just ty2) = do -- INST2 @@ -631,8 +631,8 @@ allBinders = [ identS [x] | x <- ['a'..'z'] ] ++ type Scope = [(Ident,Value)] type Sigma = Value -type Rho = Value -- No top-level ForAll -type Tau = Value -- No ForAlls anywhere +type Rho = Value -- No top-level ForAll +type Tau = Value -- No ForAlls anywhere data MetaValue = Unbound Scope Sigma @@ -724,8 +724,8 @@ getMetaVars loc sc_tys = do go (Vr tv) acc = acc go (App x y) acc = go x (go y acc) go (Meta i) acc - | i `elem` acc = acc - | otherwise = i : acc + | i `elem` acc = acc + | otherwise = i : acc go (Q _) acc = acc go (QC _) acc = acc go (Sort _) acc = acc @@ -742,9 +742,9 @@ getFreeVars loc sc_tys = do return (foldr (go []) [] tys) where go bound (Vr tv) acc - | tv `elem` bound = acc - | tv `elem` acc = acc - | otherwise = tv : acc + | tv `elem` bound = acc + | tv `elem` acc = acc + | otherwise = tv : acc go bound (App x y) acc = go bound x (go bound y acc) go bound (Meta _) acc = acc go bound (Q _) acc = acc diff --git a/src/compiler/GF/Compile/TypeCheck/TC.hs b/src/compiler/GF/Compile/TypeCheck/TC.hs index abcb24617..c0df83394 100644 --- a/src/compiler/GF/Compile/TypeCheck/TC.hs +++ b/src/compiler/GF/Compile/TypeCheck/TC.hs @@ -5,21 +5,22 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/02 20:50:19 $ +-- > CVS $Date: 2005/10/02 20:50:19 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.11 $ -- -- Thierry Coquand's type checking algorithm that creates a trace ----------------------------------------------------------------------------- -module GF.Compile.TypeCheck.TC (AExp(..), - Theory, - checkExp, - inferExp, - checkBranch, - eqVal, - whnf - ) where +module GF.Compile.TypeCheck.TC ( + AExp(..), + Theory, + checkExp, + inferExp, + checkBranch, + eqVal, + whnf + ) where import GF.Data.Operations import GF.Grammar @@ -31,17 +32,17 @@ import Data.Maybe import GF.Text.Pretty data AExp = - AVr Ident Val + AVr Ident Val | ACn QIdent Val - | AType - | AInt Int + | AType + | AInt Int | AFloat Double | AStr String | AMeta MetaId Val | ALet (Ident,(Val,AExp)) AExp - | AApp AExp AExp Val - | AAbs Ident Val AExp - | AProd Ident AExp AExp + | AApp AExp AExp Val + | AAbs Ident Val AExp + | AProd Ident AExp AExp -- -- | AEqs [([Exp],AExp)] --- not used | ARecType [ALabelling] | AR [AAssign] @@ -50,7 +51,7 @@ data AExp = | AData Val deriving (Eq,Show) -type ALabelling = (Label, AExp) +type ALabelling = (Label, AExp) type AAssign = (Label, (Val, AExp)) type Theory = QIdent -> Err Val @@ -71,7 +72,7 @@ whnf :: Val -> Err Val whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug case v of VApp u w -> do - u' <- whnf u + u' <- whnf u w' <- whnf w app u' w' VClos env e -> eval env e @@ -81,9 +82,9 @@ app :: Val -> Val -> Err Val app u v = case u of VClos env (Abs _ x e) -> eval ((x,v):env) e _ -> return $ VApp u v - + eval :: Env -> Term -> Err Val -eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ +eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ case e of Vr x -> lookupVar env x Q c -> return $ VCn c @@ -95,23 +96,23 @@ eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ _ -> return $ VClos env e eqVal :: Int -> Val -> Val -> Err [(Val,Val)] -eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ +eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ do w1 <- whnf u1 - w2 <- whnf u2 + w2 <- whnf u2 let v = VGen k case (w1,w2) of (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2) (VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) -> eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2) (VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) -> - liftM2 (++) + liftM2 (++) (eqVal k (VClos env1 a1) (VClos env2 a2)) (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)) (VGen i _, VGen j _) -> return [(w1,w2) | i /= j] - (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] + (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] --- thus ignore qualifications; valid because inheritance cannot - --- be qualified. Simplifies annotation. AR 17/3/2005 + --- be qualified. Simplifies annotation. AR 17/3/2005 _ -> return [(w1,w2) | w1 /= w2] -- invariant: constraints are in whnf @@ -127,10 +128,10 @@ checkExp th tenv@(k,rho,gamma) e ty = do Abs _ x t -> case typ of VClos env (Prod _ y a b) -> do - a' <- whnf $ VClos env a --- - (t',cs) <- checkExp th - (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) - return (AAbs x a' t', cs) + a' <- whnf $ VClos env a --- + (t',cs) <- checkExp th + (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b) + return (AAbs x a' t', cs) _ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ)) Let (x, (mb_typ, e1)) e2 -> do @@ -150,7 +151,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b return (AProd x a' b', csa ++ csb) - R xs -> + R xs -> case typ of VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of [] -> return () @@ -174,7 +175,7 @@ checkInferExp th tenv@(k,_,_) e typ = do (e',w,cs1) <- inferExp th tenv e cs2 <- eqVal k w typ return (e',cs1 ++ cs2) - + inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)]) inferExp th tenv@(k,rho,gamma) e = case e of Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x @@ -200,13 +201,13 @@ inferExp th tenv@(k,rho,gamma) e = case e of (e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2 return (ALet (x,(val1,e1)) e2, val2, cs1++cs2) App f t -> do - (f',w,csf) <- inferExp th tenv f + (f',w,csf) <- inferExp th tenv f typ <- whnf w case typ of VClos env (Prod _ x a b) -> do (a',csa) <- checkExp th tenv t (VClos env a) - b' <- whnf $ VClos ((x,VClos rho t):env) b - return $ (AApp f' a' b', b', csf ++ csa) + b' <- whnf $ VClos ((x,VClos rho t):env) b + return $ (AApp f' a' b', b', csf ++ csa) _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ)) _ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e)) @@ -232,9 +233,9 @@ checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do return ((lbl,(val,aexp)),cs) checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)]) -checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ - chB tenv' ps' ty - where +checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ + chB tenv' ps' ty + where (ps',_,rho2,k') = ps2ts k ps tenv' = (k, rho2++rho, gamma) ---- k' ? @@ -245,11 +246,11 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ typ <- whnf ty case typ of VClos env (Prod _ y a b) -> do - a' <- whnf $ VClos env a + a' <- whnf $ VClos env a (p', sigma, binds, cs1) <- checkP tenv p y a' let tenv' = (length binds, sigma ++ rho, binds ++ gamma) ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b) - return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt + return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt _ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ)) [] -> do (e,cs) <- checkExp th tenv t ty @@ -259,15 +260,15 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]] return (VClos sigma t, sigma, delta, cs) - ps2ts k = foldr p2t ([],0,[],k) + ps2ts k = foldr p2t ([],0,[],k) p2t p (ps,i,g,k) = case p of - PW -> (Meta i : ps, i+1,g,k) + PW -> (Meta i : ps, i+1,g,k) PV x -> (Vr x : ps, i, upd x k g,k+1) PAs x p -> p2t p (ps,i,g,k) PString s -> (K s : ps, i, g, k) PInt n -> (EInt n : ps, i, g, k) PFloat n -> (EFloat n : ps, i, g, k) - PP c xs -> (mkApp (Q c) xss : ps, j, g',k') + PP c xs -> (mkApp (Q c) xss : ps, j, g',k') where (xss,j,g',k') = foldr p2t ([],i,g,k) xs PImplArg p -> p2t p (ps,i,g,k) PTilde t -> (t : ps, i, g, k) @@ -307,8 +308,8 @@ checkPatt th tenv exp val = do case typ of VClos env (Prod _ x a b) -> do (a',_,csa) <- checkExpP tenv t (VClos env a) - b' <- whnf $ VClos ((x,VClos rho t):env) b - return $ (AApp f' a' b', b', csf ++ csa) + b' <- whnf $ VClos ((x,VClos rho t):env) b + return $ (AApp f' a' b', b', csf ++ csa) _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ)) _ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp)) @@ -321,4 +322,3 @@ mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)]) mkAnnot a ti = do (v,cs) <- ti return (a v, v, cs) - diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs index 4399405b8..7bbe1d8dc 100644 --- a/src/compiler/GF/Compile/Update.hs +++ b/src/compiler/GF/Compile/Update.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/05/30 18:39:44 $ +-- > CVS $Date: 2005/05/30 18:39:44 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.8 $ -- @@ -34,14 +34,14 @@ buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map I buildAnyTree m = go Map.empty where go map [] = return map - go map ((c,j):is) = do + go map ((c,j):is) = case Map.lookup c map of Just i -> case unifyAnyInfo m i j of - Ok k -> go (Map.insert c k map) is - Bad _ -> fail $ render ("conflicting information in module"<+>m $$ - nest 4 (ppJudgement Qualified (c,i)) $$ - "and" $+$ - nest 4 (ppJudgement Qualified (c,j))) + Ok k -> go (Map.insert c k map) is + Bad _ -> fail $ render ("conflicting information in module"<+>m $$ + nest 4 (ppJudgement Qualified (c,i)) $$ + "and" $+$ + nest 4 (ppJudgement Qualified (c,j))) Nothing -> go (Map.insert c j map) is extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule @@ -51,14 +51,14 @@ extendModule cwd gr (name,m) ---- Should be replaced by real control. AR 4/2/2005 | mstatus m == MSIncomplete && isModCnc m = return (name,m) | otherwise = checkInModule cwd m NoLoc empty $ do - m' <- foldM extOne m (mextend m) + m' <- foldM extOne m (mextend m) return (name,m') where extOne mo (n,cond) = do m0 <- lookupModule gr n -- test that the module types match, and find out if the old is complete - unless (sameMType (mtype m) (mtype mo)) + unless (sameMType (mtype m) (mtype mo)) (checkError ("illegal extension type to module" <+> name)) let isCompl = isCompleteModule m0 @@ -67,7 +67,7 @@ extendModule cwd gr (name,m) js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo) -- if incomplete, throw away extension information - return $ + return $ if isCompl then mo {jments = js1} else mo {mextend= filter ((/=n) . fst) (mextend mo) @@ -75,7 +75,7 @@ extendModule cwd gr (name,m) ,jments = js1 } --- | rebuilding instance + interface, and "with" modules, prior to renaming. +-- | rebuilding instance + interface, and "with" modules, prior to renaming. -- AR 24/10/2003 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) = @@ -88,8 +88,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js -- add the information given in interface into an instance module Nothing -> do - unless (null is || mstatus mi == MSIncomplete) - (checkError ("module" <+> i <+> + unless (null is || mstatus mi == MSIncomplete) + (checkError ("module" <+> i <+> "has open interfaces and must therefore be declared incomplete")) case mt of MTInstance (i0,mincl) -> do @@ -113,7 +113,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js let stat' = if all (flip elem infs) is then MSComplete else MSIncomplete - unless (stat' == MSComplete || stat == MSIncomplete) + unless (stat' == MSComplete || stat == MSIncomplete) (checkError ("module" <+> i <+> "remains incomplete")) ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext let ops1 = nub $ @@ -141,24 +141,24 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js extendMod :: Grammar -> Bool -> (Module,Ident -> Bool) -> ModuleName -> Map.Map Ident Info -> Check (Map.Map Ident Info) -extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) +extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) where try new (c,i0) | not (cond c) = return new | otherwise = case Map.lookup c new of Just j -> case unifyAnyInfo name i j of - Ok k -> return $ Map.insert c k new - Bad _ -> do (base,j) <- case j of - AnyInd _ m -> lookupOrigInfo gr (m,c) - _ -> return (base,j) - (name,i) <- case i of + Ok k -> return $ Map.insert c k new + Bad _ -> do (base,j) <- case j of + AnyInd _ m -> lookupOrigInfo gr (m,c) + _ -> return (base,j) + (name,i) <- case i of AnyInd _ m -> lookupOrigInfo gr (m,c) _ -> return (name,i) - checkError ("cannot unify the information" $$ - nest 4 (ppJudgement Qualified (c,i)) $$ - "in module" <+> name <+> "with" $$ - nest 4 (ppJudgement Qualified (c,j)) $$ - "in module" <+> base) + checkError ("cannot unify the information" $$ + nest 4 (ppJudgement Qualified (c,i)) $$ + "in module" <+> name <+> "with" $$ + nest 4 (ppJudgement Qualified (c,j)) $$ + "in module" <+> base) Nothing-> if isCompl then return $ Map.insert c (indirInfo name i) new else return $ Map.insert c i new @@ -166,11 +166,11 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme i = globalizeLoc (msrc mi) i0 indirInfo :: ModuleName -> Info -> Info - indirInfo n info = AnyInd b n' where + indirInfo n info = AnyInd b n' where (b,n') = case info of ResValue _ -> (True,n) ResParam _ _ -> (True,n) - AbsFun _ _ Nothing _ -> (True,n) + AbsFun _ _ Nothing _ -> (True,n) AnyInd b k -> (b,k) _ -> (False,n) ---- canonical in Abs @@ -194,24 +194,24 @@ globalizeLoc fpath i = unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info unifyAnyInfo m i j = case (i,j) of - (AbsCat mc1, AbsCat mc2) -> + (AbsCat mc1, AbsCat mc2) -> liftM AbsCat (unifyMaybeL mc1 mc2) - (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) -> + (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) -> liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs (ResParam mt1 mv1, ResParam mt2 mv2) -> liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2) - (ResValue (L l1 t1), ResValue (L l2 t2)) + (ResValue (L l1 t1), ResValue (L l2 t2)) | t1==t2 -> return (ResValue (L l1 t1)) | otherwise -> fail "" (_, ResOverload ms t) | elem m ms -> return $ ResOverload ms t - (ResOper mt1 m1, ResOper mt2 m2) -> + (ResOper mt1 m1, ResOper mt2 m2) -> liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2) - (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) -> + (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) -> liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2) (unifyMaybe mpmcfg1 mpmcfg2) - (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> + (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2) (AnyInd b1 m1, AnyInd b2 m2) -> do diff --git a/src/compiler/GF/Data/BacktrackM.hs b/src/compiler/GF/Data/BacktrackM.hs index 14cbf90d2..970de5c06 100644 --- a/src/compiler/GF/Data/BacktrackM.hs +++ b/src/compiler/GF/Data/BacktrackM.hs @@ -16,18 +16,18 @@ {-# LANGUAGE CPP #-} module GF.Data.BacktrackM ( -- * the backtracking state monad - BacktrackM, - -- * monad specific utilities - member, - cut, - -- * running the monad - foldBM, runBM, - foldSolutions, solutions, - foldFinalStates, finalStates, - - -- * reexport the 'MonadState' class - module Control.Monad.State.Class, - ) where + BacktrackM, + -- * monad specific utilities + member, + cut, + -- * running the monad + foldBM, runBM, + foldSolutions, solutions, + foldFinalStates, finalStates, + + -- * reexport the 'MonadState' class + module Control.Monad.State.Class, + ) where import Data.List import Control.Applicative @@ -70,7 +70,7 @@ instance Applicative (BacktrackM s) where instance Monad (BacktrackM s) where return a = BM (\c s b -> c a s b) BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b) - where unBM (BM m) = m + where unBM (BM m) = m #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail diff --git a/src/compiler/GF/Data/Graph.hs b/src/compiler/GF/Data/Graph.hs index 797325bbb..fd8ec9d99 100644 --- a/src/compiler/GF/Data/Graph.hs +++ b/src/compiler/GF/Data/Graph.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/11/10 16:43:44 $ +-- > CVS $Date: 2005/11/10 16:43:44 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.2 $ -- @@ -34,7 +34,7 @@ import Data.Set (Set) import qualified Data.Set as Set data Graph n a b = Graph [n] ![Node n a] ![Edge n b] - deriving (Eq,Show) + deriving (Eq,Show) type Node n a = (n,a) type Edge n b = (n,n,b) @@ -63,7 +63,7 @@ emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es] -- | Add a node to the graph. newNode :: a -- ^ Node label - -> Graph n a b + -> Graph n a b -> (Graph n a b,n) -- ^ Node graph and name of new node newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c) @@ -83,7 +83,7 @@ newEdges es g = foldl' (flip newEdge) g es -- lazy version: -- newEdges es' (Graph c ns es) = Graph c ns (es'++es) -insertEdgeWith :: Eq n => +insertEdgeWith :: Eq n => (b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es) where h [] = [e] @@ -97,7 +97,7 @@ removeNode n = removeNodes (Set.singleton n) -- | Remove a set of nodes and all edges to and from those nodes. removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b removeNodes xs (Graph c ns es) = Graph c ns' es' - where + where keepNode n = not (Set.member n xs) ns' = [ x | x@(n,_) <- ns, keepNode n ] es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ] @@ -105,7 +105,7 @@ removeNodes xs (Graph c ns es) = Graph c ns' es' -- | Get a map of node names to info about each node. nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ] - where + where inc = groupEdgesBy edgeTo g out = groupEdgesBy edgeFrom g fn m n = fromMaybe [] (Map.lookup n m) @@ -148,16 +148,16 @@ reverseGraph :: Graph n a b -> Graph n a b reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ] -- | Add the nodes from the second graph to the first graph. --- The nodes in the second graph will be renamed using the name +-- The nodes in the second graph will be renamed using the name -- supply in the first graph. -- This function is more efficient when the second graph -- is smaller than the first. -mergeGraphs :: Ord m => Graph n a b -> Graph m a b +mergeGraphs :: Ord m => Graph n a b -> Graph m a b -> (Graph n a b, m -> n) -- ^ The new graph and a function translating -- the old names of nodes in the second graph -- to names in the new graph. mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName) - where + where (xs,c') = splitAt (length (nodes g2)) c newNames = Map.fromList (zip (map fst (nodes g2)) xs) newName n = fromJust $ Map.lookup n newNames @@ -170,7 +170,7 @@ renameNodes :: (n -> m) -- ^ renaming function -> Graph n a b -> Graph m a b renameNodes newName c (Graph _ ns es) = Graph c ns' es' where ns' = map' (\ (n,x) -> (newName n,x)) ns - es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es + es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es -- | A strict 'map' map' :: (a -> b) -> [a] -> [b] diff --git a/src/compiler/GF/Data/Graphviz.hs b/src/compiler/GF/Data/Graphviz.hs index 411f76898..fa47bac67 100644 --- a/src/compiler/GF/Data/Graphviz.hs +++ b/src/compiler/GF/Data/Graphviz.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/15 18:10:44 $ +-- > CVS $Date: 2005/09/15 18:10:44 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.2 $ -- @@ -13,14 +13,14 @@ ----------------------------------------------------------------------------- module GF.Data.Graphviz ( - Graph(..), GraphType(..), - Node(..), Edge(..), - Attr, - addSubGraphs, - setName, - setAttr, - prGraphviz - ) where + Graph(..), GraphType(..), + Node(..), Edge(..), + Attr, + addSubGraphs, + setName, + setAttr, + prGraphviz + ) where import Data.Char @@ -70,14 +70,14 @@ prGraphviz g@(Graph t i _ _ _ _) = graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n" prSubGraph :: Graph -> String -prSubGraph g@(Graph _ i _ _ _ _) = +prSubGraph g@(Graph _ i _ _ _ _) = "subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}" prGraph :: Graph -> String -prGraph (Graph t id at ns es ss) = +prGraph (Graph t id at ns es ss) = unlines $ map (++";") (map prAttr at - ++ map prNode ns - ++ map (prEdge t) es + ++ map prNode ns + ++ map (prEdge t) es ++ map prSubGraph ss) graphtype :: GraphType -> String @@ -96,7 +96,7 @@ edgeop Undirected = "--" prAttrList :: [Attr] -> String prAttrList [] = "" -prAttrList at = "[" ++ join "," (map prAttr at) ++ "]" +prAttrList at = "[" ++ join "," (map prAttr at) ++ "]" prAttr :: Attr -> String prAttr (n,v) = esc n ++ " = " ++ esc v diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs index 08fa15c3e..e9b95f8ab 100644 --- a/src/compiler/GF/Data/Operations.hs +++ b/src/compiler/GF/Data/Operations.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/11/11 16:12:41 $ +-- > CVS $Date: 2005/11/11 16:12:41 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.22 $ -- @@ -15,34 +15,34 @@ ----------------------------------------------------------------------------- module GF.Data.Operations ( - -- ** The Error monad - Err(..), err, maybeErr, testErr, fromErr, errIn, - lookupErr, - - -- ** Error monad class - ErrorMonad(..), checks, --doUntil, allChecks, checkAgain, - liftErr, - - -- ** Checking - checkUnique, unifyMaybeBy, unifyMaybe, - - -- ** Monadic operations on lists and pairs - mapPairsM, pairM, - - -- ** Printing - indent, (+++), (++-), (++++), (+++-), (+++++), - prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, - prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes, - numberedParagraphs, prConjList, prIfEmpty, wrapLines, - - -- ** Topological sorting - topoTest, topoTest2, - - -- ** Misc - readIntArg, - iterFix, chunks, - - ) where + -- ** The Error monad + Err(..), err, maybeErr, testErr, fromErr, errIn, + lookupErr, + + -- ** Error monad class + ErrorMonad(..), checks, --doUntil, allChecks, checkAgain, + liftErr, + + -- ** Checking + checkUnique, unifyMaybeBy, unifyMaybe, + + -- ** Monadic operations on lists and pairs + mapPairsM, pairM, + + -- ** Printing + indent, (+++), (++-), (++++), (+++-), (+++++), + prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, + prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes, + numberedParagraphs, prConjList, prIfEmpty, wrapLines, + + -- ** Topological sorting + topoTest, topoTest2, + + -- ** Misc + readIntArg, + iterFix, chunks, + + ) where import Data.Char (isSpace, toUpper, isSpace, isDigit) import Data.List (nub, partition, (\\)) @@ -107,7 +107,7 @@ indent i s = replicate i ' ' ++ s (+++), (++-), (++++), (+++-), (+++++) :: String -> String -> String a +++ b = a ++ " " ++ b -a ++- "" = a +a ++- "" = a a ++- b = a +++ b a ++++ b = a ++ "\n" ++ b @@ -145,20 +145,20 @@ prCurly s = "{" ++ s ++ "}" prBracket s = "[" ++ s ++ "]" prArgList, prSemicList, prCurlyList :: [String] -> String -prArgList = prParenth . prTList "," +prArgList = prParenth . prTList "," prSemicList = prTList " ; " prCurlyList = prCurly . prSemicList restoreEscapes :: String -> String -restoreEscapes s = - case s of +restoreEscapes s = + case s of [] -> [] '"' : t -> '\\' : '"' : restoreEscapes t '\\': t -> '\\' : '\\' : restoreEscapes t c : t -> c : restoreEscapes t numberedParagraphs :: [[String]] -> [String] -numberedParagraphs t = case t of +numberedParagraphs t = case t of [] -> [] p:[] -> p _ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t] @@ -204,12 +204,12 @@ topoTest2 g0 = maybe (Right cycles) Left (tsort g) ([],[]) -> Just [] ([],_) -> Nothing (ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest] - where leaves = map fst ns + where leaves = map fst ns -- | Fix point iterator (for computing e.g. transitive closures or reachability) iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a] -iterFix more start = iter start start +iterFix more start = iter start start where iter old new = if (null new') then old @@ -241,7 +241,7 @@ liftErr e = err raise return e {- instance ErrorMonad (STM s) where raise msg = STM (\s -> raise msg) - handle (STM f) g = STM (\s -> (f s) + handle (STM f) g = STM (\s -> (f s) `handle` (\e -> let STM g' = (g e) in g' s)) diff --git a/src/compiler/GF/Data/Relation.hs b/src/compiler/GF/Data/Relation.hs index 5a3e80e6f..62da769b5 100644 --- a/src/compiler/GF/Data/Relation.hs +++ b/src/compiler/GF/Data/Relation.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/26 17:13:13 $ +-- > CVS $Date: 2005/10/26 17:13:13 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.1 $ -- @@ -83,7 +83,7 @@ transitiveClosure r = fix (Map.map growSet) r where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys) reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined. - -> Rel a -> Rel a + -> Rel a -> Rel a reflexiveClosure_ u r = relates [(x,x) | x <- u] r -- | Uses 'domain' @@ -104,7 +104,7 @@ reflexiveElements :: Ord a => Rel a -> Set a reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ] -- | Keep the related pairs for which the predicate is true. -filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a +filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p) -- | Remove keys that map to no elements. @@ -112,16 +112,16 @@ purgeEmpty :: Ord a => Rel a -> (Rel a, Set a) purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r in (r', Map.keysSet r'') --- | Get the equivalence classes from an equivalence relation. +-- | Get the equivalence classes from an equivalence relation. equivalenceClasses :: Ord a => Rel a -> [Set a] equivalenceClasses r = equivalenceClasses_ (Map.keys r) r where equivalenceClasses_ [] _ = [] equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r - where ys = allRelated r x - zs = [x' | x' <- xs, not (x' `Set.member` ys)] + where ys = allRelated r x + zs = [x' | x' <- xs, not (x' `Set.member` ys)] isTransitive :: Ord a => Rel a -> Bool -isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r, +isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r, y <- Set.toList ys, z <- Set.toList (allRelated r y)] isReflexive :: Ord a => Rel a -> Bool @@ -181,7 +181,7 @@ remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r Nothing -> (r', Set.empty, Set.empty) -- remove element from all incoming and outgoing sets -- of other elements - Just (is,os) -> + Just (is,os) -> let r'' = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r' $ Set.toList is r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os in (r''', is, os) @@ -190,4 +190,4 @@ incoming :: Ord a => a -> Rel' a -> Set a incoming x r = maybe Set.empty fst $ Map.lookup x r --outgoing :: Ord a => a -> Rel' a -> Set a ---outgoing x r = maybe Set.empty snd $ Map.lookup x r \ No newline at end of file +--outgoing x r = maybe Set.empty snd $ Map.lookup x r diff --git a/src/compiler/GF/Data/Utilities.hs b/src/compiler/GF/Data/Utilities.hs index 29ed329dc..913953b6e 100644 --- a/src/compiler/GF/Data/Utilities.hs +++ b/src/compiler/GF/Data/Utilities.hs @@ -4,7 +4,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/26 18:47:16 $ +-- > CVS $Date: 2005/10/26 18:47:16 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.6 $ -- @@ -33,7 +33,7 @@ longerThan n = not . notLongerThan n lookupList :: Eq a => a -> [(a, b)] -> [b] lookupList a [] = [] lookupList a (p:ps) | a == fst p = snd p : lookupList a ps - | otherwise = lookupList a ps + | otherwise = lookupList a ps split :: [a] -> ([a], [a]) split (x : y : as) = (x:xs, y:ys) @@ -48,8 +48,8 @@ splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys) foldMerge :: (a -> a -> a) -> a -> [a] -> a foldMerge merge zero = fm where fm [] = zero - fm [a] = a - fm abs = let (as, bs) = split abs in fm as `merge` fm bs + fm [a] = a + fm abs = let (as, bs) = split abs in fm as `merge` fm bs select :: [a] -> [(a, [a])] select [] = [] @@ -68,7 +68,7 @@ safeInit :: [a] -> [a] safeInit [] = [] safeInit xs = init xs --- | Sorts and then groups elements given an ordering of the +-- | Sorts and then groups elements given an ordering of the -- elements. sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]] sortGroupBy f = groupBy (compareEq f) . sortBy f diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index 80e9f5e7b..e62424f6a 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -45,12 +45,12 @@ data LincatDef = LincatDef CatId LinType deriving Show data LinDef = LinDef FunId [VarId] LinValue deriving Show -- | Linearization type, RHS of @lincat@ -data LinType = FloatType - | IntType +data LinType = FloatType + | IntType | ParamType ParamType | RecordType [RecordRowType] - | StrType - | TableType LinType LinType + | StrType + | TableType LinType LinType | TupleType [LinType] deriving (Eq,Ord,Show) @@ -60,7 +60,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show) data LinValue = ConcatValue LinValue LinValue | LiteralValue LinLiteral | ErrorValue String - | ParamConstant ParamValue + | ParamConstant ParamValue | PredefValue PredefId | RecordValue [RecordRowValue] | TableValue LinType [TableRowValue] @@ -74,9 +74,9 @@ data LinValue = ConcatValue LinValue LinValue | CommentedValue String LinValue deriving (Eq,Ord,Show) -data LinLiteral = FloatConstant Float - | IntConstant Int - | StrConstant String +data LinLiteral = FloatConstant Float + | IntConstant Int + | StrConstant String deriving (Eq,Ord,Show) data LinPattern = ParamPattern ParamPattern @@ -107,7 +107,7 @@ newtype PredefId = PredefId Id deriving (Eq,Ord,Show) newtype LabelId = LabelId Id deriving (Eq,Ord,Show) data VarValueId = VarValueId QualId deriving (Eq,Ord,Show) --- | Name of param type or param value +-- | Name of param type or param value newtype ParamId = ParamId QualId deriving (Eq,Ord,Show) -------------------------------------------------------------------------------- @@ -250,7 +250,7 @@ instance PPA LinLiteral where FloatConstant f -> pp f IntConstant n -> pp n StrConstant s -> doubleQuotes s -- hmm - + instance RhsSeparator LinValue where rhsSep _ = pp "=" instance Pretty LinPattern where @@ -265,7 +265,7 @@ instance PPA LinPattern where ParamPattern pv -> ppA pv RecordPattern r -> block r TuplePattern ps -> "<"<>punctuate "," ps<>">" - WildPattern -> pp "_" + WildPattern -> pp "_" instance RhsSeparator LinPattern where rhsSep _ = pp "=" diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x index bde0aa064..365388726 100644 --- a/src/compiler/GF/Grammar/Lexer.x +++ b/src/compiler/GF/Grammar/Lexer.x @@ -267,7 +267,7 @@ type AlexInput2 = (AlexInput,AlexInput) data ParseResult a = POk AlexInput2 a - | PFailed Posn -- The position of the error + | PFailed Posn -- The position of the error String -- The error message newtype P a = P { unP :: AlexInput2 -> ParseResult a } diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs index 9f774fb2c..97aa5639e 100644 --- a/src/compiler/GF/Grammar/Lookup.hs +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -6,7 +6,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/27 13:21:53 $ +-- > CVS $Date: 2005/10/27 13:21:53 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.15 $ -- @@ -20,17 +20,17 @@ module GF.Grammar.Lookup ( lookupOrigInfo, allOrigInfos, lookupResDef, lookupResDefLoc, - lookupResType, + lookupResType, lookupOverload, lookupOverloadTypes, - lookupParamValues, + lookupParamValues, allParamValues, - lookupAbsDef, - lookupLincat, + lookupAbsDef, + lookupLincat, lookupFunType, lookupCatContext, allOpers, allOpersTo - ) where + ) where import GF.Data.Operations import GF.Infra.Ident @@ -69,7 +69,7 @@ lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x) lookupResDefLoc gr (m,c) | isPredefCat c = fmap noLoc (lock c defLinType) | otherwise = look m c - where + where look m c = do info <- lookupQIdentInfo gr (m,c) case info of @@ -77,7 +77,7 @@ lookupResDefLoc gr (m,c) ResOper _ Nothing -> return (noLoc (Q (m,c))) CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty) CncCat _ _ _ _ _ -> fmap noLoc (lock c defLinType) - + CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr) CncFun _ (Just ltr) _ _ -> return ltr @@ -95,7 +95,7 @@ lookupResType gr (m,c) = do -- used in reused concrete CncCat _ _ _ _ _ -> return typeType CncFun (Just (cat,cont,val)) _ _ _ -> do - val' <- lock cat val + val' <- lock cat val return $ mkProd cont val' [] AnyInd _ n -> lookupResType gr (n,c) ResParam _ _ -> return typePType @@ -111,7 +111,7 @@ lookupOverloadTypes gr id@(m,c) = do -- used in reused concrete CncCat _ _ _ _ _ -> ret typeType CncFun (Just (cat,cont,val)) _ _ _ -> do - val' <- lock cat val + val' <- lock cat val ret $ mkProd cont val' [] ResParam _ _ -> ret typePType ResValue (L _ t) -> ret t @@ -130,8 +130,8 @@ lookupOverload gr (m,c) = do case info of ResOverload os tysts -> do tss <- mapM (\x -> lookupOverload gr (x,c)) os - return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) | - (L _ ty,L _ tr) <- tysts] ++ + return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) | + (L _ ty,L _ tr) <- tysts] ++ concat tss AnyInd _ n -> lookupOverload gr (n,c) @@ -216,7 +216,7 @@ lookupCatContext gr m c = do -- notice that it only gives the modules that are reachable and the opers that are included allOpers :: Grammar -> [(QIdent,Type,Location)] -allOpers gr = +allOpers gr = [((m,op),typ,loc) | (m,mi) <- maybe [] (allExtends gr) (greatestResource gr), (op,info) <- Map.toList (jments mi), diff --git a/src/compiler/GF/Grammar/PatternMatch.hs b/src/compiler/GF/Grammar/PatternMatch.hs index 9ef191554..dc0a5d3a5 100644 --- a/src/compiler/GF/Grammar/PatternMatch.hs +++ b/src/compiler/GF/Grammar/PatternMatch.hs @@ -5,18 +5,19 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/10/12 12:38:29 $ +-- > CVS $Date: 2005/10/12 12:38:29 $ -- > CVS $Author: aarne $ -- > CVS $Revision: 1.7 $ -- -- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003 ----------------------------------------------------------------------------- -module GF.Grammar.PatternMatch (matchPattern, - testOvershadow, - findMatch, - measurePatt - ) where +module GF.Grammar.PatternMatch ( + matchPattern, + testOvershadow, + findMatch, + measurePatt + ) where import GF.Data.Operations import GF.Grammar.Grammar @@ -30,7 +31,7 @@ import GF.Text.Pretty --import Debug.Trace matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution) -matchPattern pts term = +matchPattern pts term = if not (isInConstantForm term) then raise (render ("variables occur in" <+> pp term)) else do @@ -61,15 +62,15 @@ testOvershadow pts vs = do findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution) findMatch cases terms = case cases of [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms))) - (patts,_):_ | length patts /= length terms -> - raise (render ("wrong number of args for patterns :" <+> hsep patts <+> + (patts,_):_ | length patts /= length terms -> + raise (render ("wrong number of args for patterns :" <+> hsep patts <+> "cannot take" <+> hsep terms)) (patts,val):cc -> case mapM tryMatch (zip patts terms) of Ok substs -> return (val, concat substs) _ -> findMatch cc terms tryMatch :: (Patt, Term) -> Err [(Ident, Term)] -tryMatch (p,t) = do +tryMatch (p,t) = do t' <- termForm t trym p t' where @@ -83,26 +84,26 @@ tryMatch (p,t) = do (PString s, ([],K i,[])) | s==i -> return [] (PInt s, ([],EInt i,[])) | s==i -> return [] (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? - (PC p pp, ([], Con f, tt)) | + (PC p pp, ([], Con f, tt)) | p `eqStrIdent` f && length pp == length tt -> do matches <- mapM tryMatch (zip pp tt) return (concat matches) - (PP (q,p) pp, ([], QC (r,f), tt)) | + (PP (q,p) pp, ([], QC (r,f), tt)) | -- q `eqStrIdent` r && --- not for inherited AR 10/10/2005 p `eqStrIdent` f && length pp == length tt -> do matches <- mapM tryMatch (zip pp tt) return (concat matches) ---- hack for AppPredef bug - (PP (q,p) pp, ([], Q (r,f), tt)) | - -- q `eqStrIdent` r && --- + (PP (q,p) pp, ([], Q (r,f), tt)) | + -- q `eqStrIdent` r && --- p `eqStrIdent` f && length pp == length tt -> do matches <- mapM tryMatch (zip pp tt) return (concat matches) (PR r, ([],R r',[])) | all (`elem` map fst r') (map fst r) -> - do matches <- mapM tryMatch + do matches <- mapM tryMatch [(p,snd a) | (l,p) <- r, let Just a = lookup l r'] return (concat matches) (PT _ p',_) -> trym p' t' @@ -125,7 +126,7 @@ tryMatch (p,t) = do (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s (PRep p1, ([],K s, [])) -> checks [ - trym (foldr (const (PSeq p1)) (PString "") + trym (foldr (const (PSeq p1)) (PString "") [1..n]) t' | n <- [0 .. length s] ] >> return [] diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs index 341dae39b..74fd511b7 100644 --- a/src/compiler/GF/Grammar/Printer.hs +++ b/src/compiler/GF/Grammar/Printer.hs @@ -1,365 +1,364 @@ ----------------------------------------------------------------------- --- | --- Module : GF.Grammar.Printer --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} -module GF.Grammar.Printer - ( -- ** Pretty printing - TermPrintQual(..) - , ppModule - , ppJudgement - , ppParams - , ppTerm - , ppPatt - , ppValue - , ppConstrs - , ppQIdent - , ppMeta - , getAbs - ) where -import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint - -import GF.Infra.Ident -import GF.Infra.Option -import GF.Grammar.Values -import GF.Grammar.Grammar - -import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq) - -import GF.Text.Pretty -import Data.Maybe (isNothing) -import Data.List (intersperse) -import qualified Data.Map as Map ---import qualified Data.IntMap as IntMap ---import qualified Data.Set as Set -import qualified Data.Array.IArray as Array - -data TermPrintQual - = Terse | Unqualified | Qualified | Internal - deriving Eq - -instance Pretty Grammar where - pp = vcat . map (ppModule Qualified) . modules - -ppModule :: TermPrintQual -> SourceModule -> Doc -ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) = - hdr $$ - nest 2 (ppOptions opts $$ - vcat (map (ppJudgement q) (Map.toList jments)) $$ - maybe empty (ppSequences q) mseqs) $$ - ftr - where - hdr = complModDoc <+> modTypeDoc <+> '=' <+> - hsep (intersperse (pp "**") $ - filter (not . isEmpty) $ [ commaPunct ppExtends exts - , maybe empty ppWith with - , if null opens - then pp '{' - else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{' - ]) - - ftr = '}' - - complModDoc = - case mstat of - MSComplete -> empty - MSIncomplete -> pp "incomplete" - - modTypeDoc = - case mtype of - MTAbstract -> "abstract" <+> mn - MTResource -> "resource" <+> mn - MTConcrete abs -> "concrete" <+> mn <+> "of" <+> abs - MTInterface -> "interface" <+> mn - MTInstance ie -> "instance" <+> mn <+> "of" <+> ppExtends ie - - ppExtends (id,MIAll ) = pp id - ppExtends (id,MIOnly incs) = id <+> brackets (commaPunct pp incs) - ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs) - - ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens - -ppOptions opts = - "flags" $$ - nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts]) - -ppJudgement q (id, AbsCat pcont ) = - "cat" <+> id <+> - (case pcont of - Just (L _ cont) -> hsep (map (ppDecl q) cont) - Nothing -> empty) <+> ';' -ppJudgement q (id, AbsFun ptype _ pexp poper) = - let kind | isNothing pexp = "data" - | poper == Just False = "oper" - | otherwise = "fun" - in - (case ptype of - Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';' - Nothing -> empty) $$ - (case pexp of - Just [] -> empty - Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs] - Nothing -> empty) -ppJudgement q (id, ResParam pparams _) = - "param" <+> id <+> - (case pparams of - Just (L _ ps) -> '=' <+> ppParams q ps - _ -> empty) <+> ';' -ppJudgement q (id, ResValue pvalue) = - "-- param constructor" <+> id <+> ':' <+> - (case pvalue of - (L _ ty) -> ppTerm q 0 ty) <+> ';' -ppJudgement q (id, ResOper ptype pexp) = - "oper" <+> id <+> - (case ptype of {Just (L _ t) -> ':' <+> ppTerm q 0 t; Nothing -> empty} $$ - case pexp of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';' -ppJudgement q (id, ResOverload ids defs) = - "oper" <+> id <+> '=' <+> - ("overload" <+> '{' $$ - nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$ - '}') <+> ';' -ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) = - (case pcat of - Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';' - Nothing -> empty) $$ - (case pdef of - Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';' - Nothing -> empty) $$ - (case pref of - Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';' - Nothing -> empty) $$ - (case pprn of - Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';' - Nothing -> empty) $$ - (case (mpmcfg,q) of - (Just (PMCFG prods funs),Internal) - -> "pmcfg" <+> id <+> '=' <+> '{' $$ - nest 2 (vcat (map ppProduction prods) $$ - ' ' $$ - vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> - parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr))))) - (Array.assocs funs))) $$ - '}' - _ -> empty) -ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) = - (case pdef of - Just (L _ e) -> let (xs,e') = getAbs e - in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';' - Nothing -> empty) $$ - (case pprn of - Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';' - Nothing -> empty) $$ - (case (mpmcfg,q) of - (Just (PMCFG prods funs),Internal) - -> "pmcfg" <+> id <+> '=' <+> '{' $$ - nest 2 (vcat (map ppProduction prods) $$ - ' ' $$ - vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> - parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr))))) - (Array.assocs funs))) $$ - '}' - _ -> empty) -ppJudgement q (id, AnyInd cann mid) = - case q of - Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';' - _ -> empty - -instance Pretty Term where pp = ppTerm Unqualified 0 - -ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e) - in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e') -ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of - ([],_) -> "table" <+> '{' $$ - nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ - '}' - (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e) -ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$ - nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ - '}' -ppTerm q d (T (TComp t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$ - nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ - '}' -ppTerm q d (T (TWild t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$ - nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ - '}' -ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit - then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b) - else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b) -ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt) -ppTerm q d (Let l e) = let (ls,e') = getLet e - in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e') -ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s) -ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2)) -ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+' <+> ppTerm q 2 e2) -ppTerm q d (S x y) = case x of - T annot xs -> let e = case annot of - TRaw -> y - TTyped t -> Typed y t - TComp t -> Typed y t - TWild t -> Typed y t - in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$ - nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ - '}' - _ -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y)) -ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y) -ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y) -ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))]) -ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))) -ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) -ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs)))) -ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) -ppTerm q d (EPatt p) = prec d 4 ('#' <+> ppPatt q 2 p) -ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t) -ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> '.' <> l) -ppTerm q d (Cn id) = pp id -ppTerm q d (Vr id) = pp id -ppTerm q d (Q id) = ppQIdent q id -ppTerm q d (QC id) = ppQIdent q id -ppTerm q d (Sort id) = pp id -ppTerm q d (K s) = str s -ppTerm q d (EInt n) = pp n -ppTerm q d (EFloat f) = pp f -ppTerm q d (Meta i) = ppMeta i -ppTerm q d (Empty) = pp "[]" -ppTerm q d (R []) = pp "<>" -- to distinguish from {} empty RecType -ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+> - fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty}, - '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs])) -ppTerm q d (RecType xs) - | q == Terse = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of - [cat] -> pp cat - _ -> doc - | otherwise = doc - where - doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs])) -ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>' -ppTerm q d (ImplArg e) = braces (ppTerm q 0 e) -ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t) -ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t) -ppTerm q d (Error s) = prec d 4 ("Predef.error" <+> str s) - -ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e - -ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e - -instance Pretty Patt where pp = ppPatt Unqualified 0 - -ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2) -ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2) -ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2) -ppPatt q d (PC f ps) = if null ps - then pp f - else prec d 1 (f <+> hsep (map (ppPatt q 3) ps)) -ppPatt q d (PP f ps) = if null ps - then ppQIdent q f - else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps)) -ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> '*') -ppPatt q d (PAs f p) = prec d 2 (f <> '@' <> ppPatt q 3 p) -ppPatt q d (PNeg p) = prec d 2 ('-' <> ppPatt q 3 p) -ppPatt q d (PChar) = pp '?' -ppPatt q d (PChars s) = brackets (str s) -ppPatt q d (PMacro id) = '#' <> id -ppPatt q d (PM id) = '#' <> ppQIdent q id -ppPatt q d PW = pp '_' -ppPatt q d (PV id) = pp id -ppPatt q d (PInt n) = pp n -ppPatt q d (PFloat f) = pp f -ppPatt q d (PString s) = str s -ppPatt q d (PR xs) = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs])) -ppPatt q d (PImplArg p) = braces (ppPatt q 0 p) -ppPatt q d (PTilde t) = prec d 2 ('~' <> ppTerm q 6 t) - -ppValue :: TermPrintQual -> Int -> Val -> Doc -ppValue q d (VGen i x) = x <> "{-" <> i <> "-}" ---- latter part for debugging -ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v) -ppValue q d (VCn (_,c)) = pp c -ppValue q d (VClos env e) = case e of - Meta _ -> ppTerm q d e <> ppEnv env - _ -> ppTerm q d e ---- ++ prEnv env ---- for debugging -ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs])) -ppValue q d VType = pp "Type" - -ppConstrs :: Constraints -> [Doc] -ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w)) - -ppEnv :: Env -> Doc -ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e) - -str s = doubleQuotes s - -ppDecl q (_,id,typ) - | id == identW = ppTerm q 3 typ - | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ) - -ppDDecl q (_,id,typ) - | id == identW = ppTerm q 6 typ - | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ) - -ppQIdent :: TermPrintQual -> QIdent -> Doc -ppQIdent q (m,id) = - case q of - Terse -> pp id - Unqualified -> pp id - Qualified -> m <> '.' <> id - Internal -> m <> '.' <> id - - -instance Pretty Label where pp = pp . label2ident - -ppOpenSpec (OSimple id) = pp id -ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n) - -ppInstSpec (id,n) = parens (id <+> '=' <+> n) - -ppLocDef q (id, (mbt, e)) = - id <+> - (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';' - -ppBind (Explicit,v) = pp v -ppBind (Implicit,v) = braces v - -ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y - -ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps)) -ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt) - -ppProduction (Production fid funid args) = - ppFId fid <+> "->" <+> ppFunId funid <> - brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args))) - -ppSequences q seqsArr - | null seqs || q /= Internal = empty - | otherwise = "sequences" <+> '{' $$ - nest 2 (vcat (map ppSeq seqs)) $$ - '}' - where - seqs = Array.assocs seqsArr - -commaPunct f ds = (hcat (punctuate "," (map f ds))) - -prec d1 d2 doc - | d1 > d2 = parens doc - | otherwise = doc - -getAbs :: Term -> ([(BindType,Ident)], Term) -getAbs (Abs bt v e) = let (xs,e') = getAbs e - in ((bt,v):xs,e') -getAbs e = ([],e) - -getCTable :: Term -> ([Ident], Term) -getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e - in (v:vs,e') -getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e - in (identW:vs,e') -getCTable e = ([],e) - -getLet :: Term -> ([LocalDef], Term) -getLet (Let l e) = let (ls,e') = getLet e - in (l:ls,e') -getLet e = ([],e) - +---------------------------------------------------------------------- +-- | +-- Module : GF.Grammar.Printer +-- Maintainer : Krasimir Angelov +-- Stability : (stable) +-- Portability : (portable) +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE FlexibleContexts #-} +module GF.Grammar.Printer + ( -- ** Pretty printing + TermPrintQual(..) + , ppModule + , ppJudgement + , ppParams + , ppTerm + , ppPatt + , ppValue + , ppConstrs + , ppQIdent + , ppMeta + , getAbs + ) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint + +import GF.Infra.Ident +import GF.Infra.Option +import GF.Grammar.Values +import GF.Grammar.Grammar + +import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq) + +import GF.Text.Pretty +import Data.Maybe (isNothing) +import Data.List (intersperse) +import qualified Data.Map as Map +--import qualified Data.IntMap as IntMap +--import qualified Data.Set as Set +import qualified Data.Array.IArray as Array + +data TermPrintQual + = Terse | Unqualified | Qualified | Internal + deriving Eq + +instance Pretty Grammar where + pp = vcat . map (ppModule Qualified) . modules + +ppModule :: TermPrintQual -> SourceModule -> Doc +ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) = + hdr $$ + nest 2 (ppOptions opts $$ + vcat (map (ppJudgement q) (Map.toList jments)) $$ + maybe empty (ppSequences q) mseqs) $$ + ftr + where + hdr = complModDoc <+> modTypeDoc <+> '=' <+> + hsep (intersperse (pp "**") $ + filter (not . isEmpty) $ [ commaPunct ppExtends exts + , maybe empty ppWith with + , if null opens + then pp '{' + else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{' + ]) + + ftr = '}' + + complModDoc = + case mstat of + MSComplete -> empty + MSIncomplete -> pp "incomplete" + + modTypeDoc = + case mtype of + MTAbstract -> "abstract" <+> mn + MTResource -> "resource" <+> mn + MTConcrete abs -> "concrete" <+> mn <+> "of" <+> abs + MTInterface -> "interface" <+> mn + MTInstance ie -> "instance" <+> mn <+> "of" <+> ppExtends ie + + ppExtends (id,MIAll ) = pp id + ppExtends (id,MIOnly incs) = id <+> brackets (commaPunct pp incs) + ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs) + + ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens + +ppOptions opts = + "flags" $$ + nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts]) + +ppJudgement q (id, AbsCat pcont ) = + "cat" <+> id <+> + (case pcont of + Just (L _ cont) -> hsep (map (ppDecl q) cont) + Nothing -> empty) <+> ';' +ppJudgement q (id, AbsFun ptype _ pexp poper) = + let kind | isNothing pexp = "data" + | poper == Just False = "oper" + | otherwise = "fun" + in + (case ptype of + Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';' + Nothing -> empty) $$ + (case pexp of + Just [] -> empty + Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs] + Nothing -> empty) +ppJudgement q (id, ResParam pparams _) = + "param" <+> id <+> + (case pparams of + Just (L _ ps) -> '=' <+> ppParams q ps + _ -> empty) <+> ';' +ppJudgement q (id, ResValue pvalue) = + "-- param constructor" <+> id <+> ':' <+> + (case pvalue of + (L _ ty) -> ppTerm q 0 ty) <+> ';' +ppJudgement q (id, ResOper ptype pexp) = + "oper" <+> id <+> + (case ptype of {Just (L _ t) -> ':' <+> ppTerm q 0 t; Nothing -> empty} $$ + case pexp of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';' +ppJudgement q (id, ResOverload ids defs) = + "oper" <+> id <+> '=' <+> + ("overload" <+> '{' $$ + nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$ + '}') <+> ';' +ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) = + (case pcat of + Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';' + Nothing -> empty) $$ + (case pdef of + Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';' + Nothing -> empty) $$ + (case pref of + Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';' + Nothing -> empty) $$ + (case pprn of + Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';' + Nothing -> empty) $$ + (case (mpmcfg,q) of + (Just (PMCFG prods funs),Internal) + -> "pmcfg" <+> id <+> '=' <+> '{' $$ + nest 2 (vcat (map ppProduction prods) $$ + ' ' $$ + vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> + parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr))))) + (Array.assocs funs))) $$ + '}' + _ -> empty) +ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) = + (case pdef of + Just (L _ e) -> let (xs,e') = getAbs e + in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';' + Nothing -> empty) $$ + (case pprn of + Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';' + Nothing -> empty) $$ + (case (mpmcfg,q) of + (Just (PMCFG prods funs),Internal) + -> "pmcfg" <+> id <+> '=' <+> '{' $$ + nest 2 (vcat (map ppProduction prods) $$ + ' ' $$ + vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> + parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr))))) + (Array.assocs funs))) $$ + '}' + _ -> empty) +ppJudgement q (id, AnyInd cann mid) = + case q of + Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';' + _ -> empty + +instance Pretty Term where pp = ppTerm Unqualified 0 + +ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e) + in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e') +ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of + ([],_) -> "table" <+> '{' $$ + nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ + '}' + (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e) +ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$ + nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ + '}' +ppTerm q d (T (TComp t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$ + nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ + '}' +ppTerm q d (T (TWild t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$ + nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ + '}' +ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit + then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b) + else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b) +ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt) +ppTerm q d (Let l e) = let (ls,e') = getLet e + in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e') +ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s) +ppTerm q d (C e1 e2) =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2)) +ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+' <+> ppTerm q 2 e2) +ppTerm q d (S x y) = case x of + T annot xs -> let e = case annot of + TRaw -> y + TTyped t -> Typed y t + TComp t -> Typed y t + TWild t -> Typed y t + in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$ + nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$ + '}' + _ -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y)) +ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y) +ppTerm q d (App x y) = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y) +ppTerm q d (V e es) = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))]) +ppTerm q d (FV es) = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))) +ppTerm q d (AdHocOverload es) = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) +ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs)))) +ppTerm q d (Strs es) = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))) +ppTerm q d (EPatt p) = prec d 4 ('#' <+> ppPatt q 2 p) +ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t) +ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> '.' <> l) +ppTerm q d (Cn id) = pp id +ppTerm q d (Vr id) = pp id +ppTerm q d (Q id) = ppQIdent q id +ppTerm q d (QC id) = ppQIdent q id +ppTerm q d (Sort id) = pp id +ppTerm q d (K s) = str s +ppTerm q d (EInt n) = pp n +ppTerm q d (EFloat f) = pp f +ppTerm q d (Meta i) = ppMeta i +ppTerm q d (Empty) = pp "[]" +ppTerm q d (R []) = pp "<>" -- to distinguish from {} empty RecType +ppTerm q d (R xs) = braces (fsep (punctuate ';' [l <+> + fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty}, + '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs])) +ppTerm q d (RecType xs) + | q == Terse = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of + [cat] -> pp cat + _ -> doc + | otherwise = doc + where + doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs])) +ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>' +ppTerm q d (ImplArg e) = braces (ppTerm q 0 e) +ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t) +ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t) +ppTerm q d (Error s) = prec d 4 ("Predef.error" <+> str s) + +ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e + +ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e + +instance Pretty Patt where pp = ppPatt Unqualified 0 + +ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2) +ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2) +ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2) +ppPatt q d (PC f ps) = if null ps + then pp f + else prec d 1 (f <+> hsep (map (ppPatt q 3) ps)) +ppPatt q d (PP f ps) = if null ps + then ppQIdent q f + else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps)) +ppPatt q d (PRep p) = prec d 1 (ppPatt q 3 p <> '*') +ppPatt q d (PAs f p) = prec d 2 (f <> '@' <> ppPatt q 3 p) +ppPatt q d (PNeg p) = prec d 2 ('-' <> ppPatt q 3 p) +ppPatt q d (PChar) = pp '?' +ppPatt q d (PChars s) = brackets (str s) +ppPatt q d (PMacro id) = '#' <> id +ppPatt q d (PM id) = '#' <> ppQIdent q id +ppPatt q d PW = pp '_' +ppPatt q d (PV id) = pp id +ppPatt q d (PInt n) = pp n +ppPatt q d (PFloat f) = pp f +ppPatt q d (PString s) = str s +ppPatt q d (PR xs) = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs])) +ppPatt q d (PImplArg p) = braces (ppPatt q 0 p) +ppPatt q d (PTilde t) = prec d 2 ('~' <> ppTerm q 6 t) + +ppValue :: TermPrintQual -> Int -> Val -> Doc +ppValue q d (VGen i x) = x <> "{-" <> i <> "-}" ---- latter part for debugging +ppValue q d (VApp u v) = prec d 4 (ppValue q 4 u <+> ppValue q 5 v) +ppValue q d (VCn (_,c)) = pp c +ppValue q d (VClos env e) = case e of + Meta _ -> ppTerm q d e <> ppEnv env + _ -> ppTerm q d e ---- ++ prEnv env ---- for debugging +ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs])) +ppValue q d VType = pp "Type" + +ppConstrs :: Constraints -> [Doc] +ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w)) + +ppEnv :: Env -> Doc +ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e) + +str s = doubleQuotes s + +ppDecl q (_,id,typ) + | id == identW = ppTerm q 3 typ + | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ) + +ppDDecl q (_,id,typ) + | id == identW = ppTerm q 6 typ + | otherwise = parens (id <+> ':' <+> ppTerm q 0 typ) + +ppQIdent :: TermPrintQual -> QIdent -> Doc +ppQIdent q (m,id) = + case q of + Terse -> pp id + Unqualified -> pp id + Qualified -> m <> '.' <> id + Internal -> m <> '.' <> id + + +instance Pretty Label where pp = pp . label2ident + +ppOpenSpec (OSimple id) = pp id +ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n) + +ppInstSpec (id,n) = parens (id <+> '=' <+> n) + +ppLocDef q (id, (mbt, e)) = + id <+> + (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';' + +ppBind (Explicit,v) = pp v +ppBind (Implicit,v) = braces v + +ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y + +ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps)) +ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt) + +ppProduction (Production fid funid args) = + ppFId fid <+> "->" <+> ppFunId funid <> + brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args))) + +ppSequences q seqsArr + | null seqs || q /= Internal = empty + | otherwise = "sequences" <+> '{' $$ + nest 2 (vcat (map ppSeq seqs)) $$ + '}' + where + seqs = Array.assocs seqsArr + +commaPunct f ds = (hcat (punctuate "," (map f ds))) + +prec d1 d2 doc + | d1 > d2 = parens doc + | otherwise = doc + +getAbs :: Term -> ([(BindType,Ident)], Term) +getAbs (Abs bt v e) = let (xs,e') = getAbs e + in ((bt,v):xs,e') +getAbs e = ([],e) + +getCTable :: Term -> ([Ident], Term) +getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e + in (v:vs,e') +getCTable (T TRaw [(PW, e)]) = let (vs,e') = getCTable e + in (identW:vs,e') +getCTable e = ([],e) + +getLet :: Term -> ([LocalDef], Term) +getLet (Let l e) = let (ls,e') = getLet e + in (l:ls,e') +getLet e = ([],e) diff --git a/src/compiler/GF/Grammar/Values.hs b/src/compiler/GF/Grammar/Values.hs index 3cfd79ad7..c8fcb3945 100644 --- a/src/compiler/GF/Grammar/Values.hs +++ b/src/compiler/GF/Grammar/Values.hs @@ -5,22 +5,23 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/21 16:22:32 $ +-- > CVS $Date: 2005/04/21 16:22:32 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.7 $ -- -- (Description of the module) ----------------------------------------------------------------------------- -module GF.Grammar.Values (-- ** Values used in TC type checking - Val(..), Env, - -- ** Annotated tree used in editing +module GF.Grammar.Values ( + -- ** Values used in TC type checking + Val(..), Env, + -- ** Annotated tree used in editing Binds, Constraints, MetaSubst, - -- ** For TC - valAbsInt, valAbsFloat, valAbsString, vType, - isPredefCat, - eType, - ) where + -- ** For TC + valAbsInt, valAbsFloat, valAbsString, vType, + isPredefCat, + eType, + ) where import GF.Infra.Ident import GF.Grammar.Grammar diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index c0234999a..a5ff7148a 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/21 16:22:33 $ +-- > CVS $Date: 2005/04/21 16:22:33 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.5 $ -- @@ -14,10 +14,10 @@ module GF.Infra.CheckM (Check, CheckResult, Message, runCheck, runCheck', - checkError, checkCond, checkWarn, checkWarnings, checkAccumError, - checkIn, checkInModule, checkMap, checkMapRecover, + checkError, checkCond, checkWarn, checkWarnings, checkAccumError, + checkIn, checkInModule, checkMap, checkMapRecover, parallelCheck, accumulateError, commitCheck, - ) where + ) where import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import GF.Data.Operations @@ -141,10 +141,10 @@ checkMapRecover f = fmap Map.fromList . parallelCheck . map f' . Map.toList where f' (k,v) = fmap ((,)k) (f k v) {- -checkMapRecover f mp = do +checkMapRecover f mp = do let xs = map (\ (k,v) -> (k,runCheck (f k v))) (Map.toList mp) case [s | (_,Bad s) <- xs] of - ss@(_:_) -> checkError (text (unlines ss)) + ss@(_:_) -> checkError (text (unlines ss)) _ -> do let (kx,ss) = unzip [((k,x),s) | (k, Ok (x,s)) <- xs] if not (all null ss) then checkWarn (text (unlines ss)) else return () diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 855ab22d1..1ea62e4b3 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -433,7 +433,7 @@ wc_type = cmd_name x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1 cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of - [x] -> Just x + [x] -> Just x _ -> Nothing isIdent c = c == '_' || c == '\'' || isAlphaNum c diff --git a/src/compiler/GF/Speech/FiniteState.hs b/src/compiler/GF/Speech/FiniteState.hs index cb5247755..95acd35c5 100644 --- a/src/compiler/GF/Speech/FiniteState.hs +++ b/src/compiler/GF/Speech/FiniteState.hs @@ -5,37 +5,37 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/11/10 16:43:44 $ +-- > CVS $Date: 2005/11/10 16:43:44 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.16 $ -- -- A simple finite state network module. ----------------------------------------------------------------------------- module GF.Speech.FiniteState (FA(..), State, NFA, DFA, - startState, finalStates, - states, transitions, + startState, finalStates, + states, transitions, isInternal, - newFA, newFA_, - addFinalState, - newState, newStates, + newFA, newFA_, + addFinalState, + newState, newStates, newTransition, newTransitions, insertTransitionWith, insertTransitionsWith, - mapStates, mapTransitions, + mapStates, mapTransitions, modifyTransitions, - nonLoopTransitionsTo, nonLoopTransitionsFrom, + nonLoopTransitionsTo, nonLoopTransitionsFrom, loops, removeState, oneFinalState, insertNFA, onGraph, - moveLabelsToNodes, removeTrivialEmptyNodes, + moveLabelsToNodes, removeTrivialEmptyNodes, minimize, dfa2nfa, unusedNames, renameStates, - prFAGraphviz, faToGraphviz) where + prFAGraphviz, faToGraphviz) where import Data.List -import Data.Maybe +import Data.Maybe --import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -98,13 +98,13 @@ newTransition f t l = onGraph (newEdge (f,t,l)) newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b newTransitions es = onGraph (newEdges es) -insertTransitionWith :: Eq n => +insertTransitionWith :: Eq n => (b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b insertTransitionWith f t = onGraph (insertEdgeWith f t) -insertTransitionsWith :: Eq n => +insertTransitionsWith :: Eq n => (b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b -insertTransitionsWith f ts fa = +insertTransitionsWith f ts fa = foldl' (flip (insertTransitionWith f)) fa ts mapStates :: (a -> c) -> FA n a b -> FA n c b @@ -128,11 +128,11 @@ unusedNames (FA (Graph names _ _) _ _) = names -- | Gets all incoming transitions to a given state, excluding -- transtions from the state itself. nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)] -nonLoopTransitionsTo s fa = +nonLoopTransitionsTo s fa = [(f,l) | (f,t,l) <- transitions fa, t == s && f /= s] nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)] -nonLoopTransitionsFrom s fa = +nonLoopTransitionsFrom s fa = [(t,l) | (f,t,l) <- transitions fa, f == s && t /= s] loops :: Eq n => n -> FA n a b -> [b] @@ -145,7 +145,7 @@ renameStates :: Ord x => [y] -- ^ Infinite supply of new names renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs' where (ns,rest) = splitAt (length (nodes g)) supply newNodes = Map.fromList (zip (map fst (nodes g)) ns) - newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes + newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes s' = newName s fs' = map newName fs @@ -154,9 +154,9 @@ insertNFA :: NFA a -- ^ NFA to insert into -> (State, State) -- ^ States to insert between -> NFA a -- ^ NFA to insert. -> NFA a -insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2) +insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2) = FA (newEdges es g') s1 fs1 - where + where es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2] (g',ren) = mergeGraphs g1 g2 @@ -182,9 +182,9 @@ oneFinalState nl el fa = moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) () moveLabelsToNodes = onGraph f where f g@(Graph c _ _) = Graph c' ns (concat ess) - where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)] - (c',is') = mapAccumL fixIncoming c is - (ns,ess) = unzip (concat is') + where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)] + (c',is') = mapAccumL fixIncoming c is + (ns,ess) = unzip (concat is') -- | Remove empty nodes which are not start or final, and have @@ -196,12 +196,12 @@ removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes -- This is not done if the pointed-to node is a final node. skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) () skipSimpleEmptyNodes fa = onGraph og fa - where + where og g@(Graph c ns es) = if es' == es then g else og (Graph c ns es') where es' = concatMap changeEdge es info = nodeInfo g - changeEdge e@(f,t,()) + changeEdge e@(f,t,()) | isNothing (getNodeLabel info t) -- && (i * o <= i + o) && not (isFinal fa t) @@ -223,28 +223,28 @@ pruneUnusable fa = onGraph f fa where f g = if Set.null rns then g else f (removeNodes rns g) where info = nodeInfo g - rns = Set.fromList [ n | (n,_) <- nodes g, + rns = Set.fromList [ n | (n,_) <- nodes g, isInternal fa n, - inDegree info n == 0 + inDegree info n == 0 || outDegree info n == 0] -fixIncoming :: (Ord n, Eq a) => [n] +fixIncoming :: (Ord n, Eq a) => [n] -> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges -> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their -- incoming edges. fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts) where ls = nub $ map edgeLabel es - (cs',cs'') = splitAt (length ls) cs - newNodes = zip cs' ls - es' = [ (x,n,()) | x <- map fst newNodes ] - -- separate cyclic and non-cyclic edges - (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es - -- keep all incoming non-cyclic edges with the right label - to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l'] - -- for each cyclic edge with the right label, - -- add an edge from each of the new nodes (including this one) - ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes] - newContexts = [ (v, to v) | v <- newNodes ] + (cs',cs'') = splitAt (length ls) cs + newNodes = zip cs' ls + es' = [ (x,n,()) | x <- map fst newNodes ] + -- separate cyclic and non-cyclic edges + (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es + -- keep all incoming non-cyclic edges with the right label + to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l'] + -- for each cyclic edge with the right label, + -- add an edge from each of the new nodes (including this one) + ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes] + newContexts = [ (v, to v) | v <- newNodes ] --alphabet :: Eq b => Graph n a (Maybe b) -> [b] --alphabet = nub . catMaybes . map edgeLabel . edges @@ -254,19 +254,19 @@ determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.emp (ns',es') = (Set.toList ns, Set.toList es) final = filter isDFAFinal ns' fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final - in renameStates [0..] fa + in renameStates [0..] fa where info = nodeInfo g -- reach = nodesReachable out - start = closure info $ Set.singleton s + start = closure info $ Set.singleton s isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n)) - h currentStates oldStates es - | Set.null currentStates = (oldStates,es) - | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es' - where - allOldStates = oldStates `Set.union` currentStates + h currentStates oldStates es + | Set.null currentStates = (oldStates,es) + | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es' + where + allOldStates = oldStates `Set.union` currentStates (newStates,es') = new (Set.toList currentStates) Set.empty es - uniqueNewStates = newStates Set.\\ allOldStates - -- Get the sets of states reachable from the given states + uniqueNewStates = newStates Set.\\ allOldStates + -- Get the sets of states reachable from the given states -- by consuming one symbol, and the associated edges. new [] rs es = (rs,es) new (n:ns) rs es = new ns rs' es' @@ -281,7 +281,7 @@ closure info x = closure_ x x where closure_ acc check | Set.null check = acc | otherwise = closure_ acc' check' where - reach = Set.fromList [y | x <- Set.toList check, + reach = Set.fromList [y | x <- Set.toList check, (_,y,Nothing) <- getOutgoing info x] acc' = acc `Set.union` reach check' = reach Set.\\ acc @@ -296,8 +296,8 @@ reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y, reverseNFA :: NFA a -> NFA a reverseNFA (FA g s fs) = FA g''' s' [s] where g' = reverseGraph g - (g'',s') = newNode () g' - g''' = newEdges [(s',f,Nothing) | f <- fs] g'' + (g'',s') = newNode () g' + g''' = newEdges [(s',f,Nothing) | f <- fs] g'' dfa2nfa :: DFA a -> NFA a dfa2nfa = mapTransitions Just @@ -313,13 +313,13 @@ prFAGraphviz = Dot.prGraphviz . faToGraphviz --prFAGraphviz_ = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph -faToGraphviz (FA (Graph _ ns es) s f) +faToGraphviz (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) [] where mkNode (n,l) = Dot.Node (show n) attrs - where attrs = [("label",l)] - ++ if n == s then [("shape","box")] else [] - ++ if n `elem` f then [("style","bold")] else [] - mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)] + where attrs = [("label",l)] + ++ if n == s then [("shape","box")] else [] + ++ if n `elem` f then [("style","bold")] else [] + mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)] -- -- * Utilities diff --git a/src/compiler/GF/Speech/GSL.hs b/src/compiler/GF/Speech/GSL.hs index a898a4bb5..ceaf86ae0 100644 --- a/src/compiler/GF/Speech/GSL.hs +++ b/src/compiler/GF/Speech/GSL.hs @@ -26,14 +26,14 @@ width = 75 gslPrinter :: Options -> PGF -> CId -> String gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc - where st = style { lineLength = width } + where st = style { lineLength = width } prGSL :: SRG -> Doc prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg)) where header = ";GSL2.0" $$ - comment ("Nuance speech recognition grammar for " ++ srgName srg) $$ - comment ("Generated by GF") + comment ("Nuance speech recognition grammar for " ++ srgName srg) $$ + comment ("Generated by GF") mainCat = ".MAIN" <+> prCat (srgStartCat srg) prRule (SRGRule cat rhs) = prCat cat <+> union (map prAlt rhs) -- FIXME: use the probability diff --git a/src/compiler/GF/Speech/JSGF.hs b/src/compiler/GF/Speech/JSGF.hs index 15f5ff69d..b12fb0ace 100644 --- a/src/compiler/GF/Speech/JSGF.hs +++ b/src/compiler/GF/Speech/JSGF.hs @@ -31,7 +31,7 @@ width :: Int width = 75 jsgfPrinter :: Options - -> PGF + -> PGF -> CId -> String jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc where st = style { lineLength = width } @@ -44,7 +44,7 @@ prJSGF sisr srg header = "#JSGF" <+> "V1.0" <+> "UTF-8" <+> lang <> ';' $$ comment ("JSGF speech recognition grammar for " ++ srgName srg) $$ comment "Generated by GF" $$ - ("grammar " ++ srgName srg ++ ";") + ("grammar " ++ srgName srg ++ ";") lang = maybe empty pp (srgLanguage srg) mainCat = rule True "MAIN" [prCat (srgStartCat srg)] prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs) @@ -62,7 +62,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc prItem sisr t = f 0 where f _ (REUnion []) = pp "" - f p (REUnion xs) + f p (REUnion xs) | not (null es) = brackets (f 0 (REUnion nes)) | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs)) where (es,nes) = partition isEpsilon xs @@ -110,4 +110,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs ($++$) :: Doc -> Doc -> Doc x $++$ y = x $$ emptyLine $$ y - diff --git a/src/compiler/GF/Speech/PGFToCFG.hs b/src/compiler/GF/Speech/PGFToCFG.hs index a8ecec27d..fdd8a6c84 100644 --- a/src/compiler/GF/Speech/PGFToCFG.hs +++ b/src/compiler/GF/Speech/PGFToCFG.hs @@ -28,7 +28,7 @@ toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc type Profile = [Int] -pgfToCFG :: PGF +pgfToCFG :: PGF -> CId -- ^ Concrete syntax name -> CFG pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap ruleToCFRule rules) @@ -40,8 +40,8 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co , prod <- Set.toList set] fcatCats :: Map FId Cat - fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i) - | (c,CncCat s e lbls) <- Map.toList (cnccats cnc), + fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i) + | (c,CncCat s e lbls) <- Map.toList (cnccats cnc), (fc,i) <- zip (range (s,e)) [1..]] fcatCat :: FId -> Cat @@ -58,7 +58,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co topdownRules cat = f cat [] where f cat rules = maybe rules (Set.foldr g rules) (IntMap.lookup cat (productions cnc)) - + g (PApply funid args) rules = (cncfuns cnc ! funid,args) : rules g (PCoerce cat) rules = f cat rules @@ -67,13 +67,13 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co extCats = Set.fromList $ map ruleLhs startRules startRules :: [CFRule] - startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0) - | (c,CncCat s e lbls) <- Map.toList (cnccats cnc), + startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0) + | (c,CncCat s e lbls) <- Map.toList (cnccats cnc), fc <- range (s,e), not (isPredefFId fc), r <- [0..catLinArity fc-1]] ruleToCFRule :: (FId,Production) -> [CFRule] - ruleToCFRule (c,PApply funid args) = + ruleToCFRule (c,PApply funid args) = [Rule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]]) | (l,seqid) <- Array.assocs rhs , let row = sequences cnc ! seqid @@ -106,7 +106,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co fixProfile row i = [k | (k,j) <- nts, j == i] where nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt] - + getPos (SymCat j _) = [j] getPos (SymLit j _) = [j] getPos _ = [] diff --git a/src/compiler/GF/Speech/SRG.hs b/src/compiler/GF/Speech/SRG.hs index 9d51e52e9..b761c45cd 100644 --- a/src/compiler/GF/Speech/SRG.hs +++ b/src/compiler/GF/Speech/SRG.hs @@ -2,8 +2,8 @@ -- | -- Module : SRG -- --- Representation of, conversion to, and utilities for --- printing of a general Speech Recognition Grammar. +-- Representation of, conversion to, and utilities for +-- printing of a general Speech Recognition Grammar. -- -- FIXME: remove \/ warn \/ fail if there are int \/ string literal -- categories in the grammar @@ -40,20 +40,20 @@ import qualified Data.Set as Set --import Debug.Trace data SRG = SRG { srgName :: String -- ^ grammar name - , srgStartCat :: Cat -- ^ start category name - , srgExternalCats :: Set Cat - , srgLanguage :: Maybe String -- ^ The language for which the grammar - -- is intended, e.g. en-UK - , srgRules :: [SRGRule] - } - deriving (Eq,Show) + , srgStartCat :: Cat -- ^ start category name + , srgExternalCats :: Set Cat + , srgLanguage :: Maybe String -- ^ The language for which the grammar + -- is intended, e.g. en-UK + , srgRules :: [SRGRule] + } + deriving (Eq,Show) data SRGRule = SRGRule Cat [SRGAlt] - deriving (Eq,Show) + deriving (Eq,Show) -- | maybe a probability, a rule name and an EBNF right-hand side data SRGAlt = SRGAlt (Maybe Double) CFTerm SRGItem - deriving (Eq,Show) + deriving (Eq,Show) type SRGItem = RE SRGSymbol @@ -65,7 +65,7 @@ type SRGNT = (Cat, Int) ebnfPrinter :: Options -> PGF -> CId -> String ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc --- | Create a compact filtered non-left-recursive SRG. +-- | Create a compact filtered non-left-recursive SRG. makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG makeNonLeftRecursiveSRG opts = makeSRG opts' where @@ -76,11 +76,11 @@ makeSRG opts = mkSRG cfgToSRG preprocess where cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg] preprocess = maybeTransform opts CFGMergeIdentical mergeIdentical - . maybeTransform opts CFGNoLR removeLeftRecursion + . maybeTransform opts CFGNoLR removeLeftRecursion . maybeTransform opts CFGRegular makeRegular . maybeTransform opts CFGTopDownFilter topDownFilter . maybeTransform opts CFGBottomUpFilter bottomUpFilter - . maybeTransform opts CFGRemoveCycles removeCycles + . maybeTransform opts CFGRemoveCycles removeCycles . maybeTransform opts CFGStartCatOnly purgeExternalCats setDefaultCFGTransform :: Options -> CFGTransform -> Bool -> Options @@ -95,7 +95,7 @@ stats g = "Categories: " ++ show (countCats g) ++ ", External categories: " ++ show (Set.size (cfgExternalCats g)) ++ ", Rules: " ++ show (countRules g) -} -makeNonRecursiveSRG :: Options +makeNonRecursiveSRG :: Options -> PGF -> CId -- ^ Concrete syntax name. -> SRG @@ -111,26 +111,26 @@ makeNonRecursiveSRG opts = mkSRG cfgToSRG id mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG mkSRG mkRules preprocess pgf cnc = SRG { srgName = showCId cnc, - srgStartCat = cfgStartCat cfg, + srgStartCat = cfgStartCat cfg, srgExternalCats = cfgExternalCats cfg, srgLanguage = languageCode pgf cnc, - srgRules = mkRules cfg } + srgRules = mkRules cfg } where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc --- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string), +-- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string), -- to C_N where N is an integer. renameCats :: String -> CFG -> CFG renameCats prefix cfg = mapCFGCats renameCat cfg where renameCat c | isExternal c = c ++ "_cat" | otherwise = Map.findWithDefault (badCat c) c names - isExternal c = c `Set.member` cfgExternalCats cfg + isExternal c = c `Set.member` cfgExternalCats cfg catsByPrefix = buildMultiMap [(takeWhile (/='_') cat, cat) | cat <- allCats' cfg, not (isExternal cat)] names = Map.fromList [(c,pref++"_"++show i) | (pref,cs) <- catsByPrefix, (c,i) <- zip cs [1..]] badCat c = error ("GF.Speech.SRG.renameCats: " ++ c ++ "\n" ++ prCFG cfg) cfRulesToSRGRule :: [CFRule] -> SRGRule cfRulesToSRGRule rs@(r:_) = SRGRule (ruleLhs r) rhs - where + where alts = [((n,Nothing),mkSRGSymbols 0 ss) | Rule c ss n <- rs] rhs = [SRGAlt p n (srgItem sss) | ((n,p),sss) <- buildMultiMap alts ] @@ -153,7 +153,7 @@ srgItem = unionRE . map mergeItems . sortGroupBy (compareBy filterCats) -- non-optimizing version: --srgItem = unionRE . map seqRE --- | Merges a list of right-hand sides which all have the same +-- | Merges a list of right-hand sides which all have the same -- sequence of non-terminals. mergeItems :: [[SRGSymbol]] -> SRGItem mergeItems = minimizeRE . ungroupTokens . minimizeRE . unionRE . map seqRE . map groupTokens @@ -174,16 +174,16 @@ ungroupTokens = joinRE . mapRE (symbol (RESymbol . NonTerminal) (REConcat . map prSRG :: Options -> SRG -> String prSRG opts srg = prProductions $ map prRule $ ext ++ int - where + where sisr = flag optSISR opts (ext,int) = partition (isExternalCat srg . srgLHSCat) (srgRules srg) prRule (SRGRule c alts) = (c,unwords (intersperse "|" (concatMap prAlt alts))) - prAlt (SRGAlt _ t rhs) = - -- FIXME: hack: we high-jack the --sisr flag to add + prAlt (SRGAlt _ t rhs) = + -- FIXME: hack: we high-jack the --sisr flag to add -- a simple lambda calculus format for semantic interpretation -- Maybe the --sisr flag should be renamed. case sisr of - Just _ -> + Just _ -> -- copy tags to each part of a top-level union, -- to get simpler output case rhs of diff --git a/src/compiler/GF/Speech/SRGS_ABNF.hs b/src/compiler/GF/Speech/SRGS_ABNF.hs index dc5c7bbd3..3db8fe7c2 100644 --- a/src/compiler/GF/Speech/SRGS_ABNF.hs +++ b/src/compiler/GF/Speech/SRGS_ABNF.hs @@ -5,7 +5,7 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/11/01 20:09:04 $ +-- > CVS $Date: 2005/11/01 20:09:04 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.16 $ -- @@ -38,7 +38,7 @@ width :: Int width = 75 srgsAbnfPrinter :: Options - -> PGF -> CId -> String + -> PGF -> CId -> String srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc where sisr = flag optSISR opts @@ -72,7 +72,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc prItem sisr t = f 0 where f _ (REUnion []) = pp "$VOID" - f p (REUnion xs) + f p (REUnion xs) | not (null es) = brackets (f 0 (REUnion nes)) | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs)) where (es,nes) = partition isEpsilon xs @@ -84,13 +84,13 @@ prItem sisr t = f 0 prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n) -prSymbol _ cn (Terminal t) +prSymbol _ cn (Terminal t) | all isPunct t = empty -- removes punctuation | otherwise = pp t -- FIXME: quote if there is whitespace or odd chars tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc tag Nothing _ = empty -tag (Just fmt) t = +tag (Just fmt) t = case t fmt of [] -> empty -- grr, silly SRGS ABNF does not have an escaping mechanism @@ -125,4 +125,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs ($++$) :: Doc -> Doc -> Doc x $++$ y = x $$ emptyLine $$ y - diff --git a/src/compiler/GF/Speech/SRGS_XML.hs b/src/compiler/GF/Speech/SRGS_XML.hs index 397bfb739..17d8eec5c 100644 --- a/src/compiler/GF/Speech/SRGS_XML.hs +++ b/src/compiler/GF/Speech/SRGS_XML.hs @@ -34,13 +34,13 @@ prSrgsXml :: Maybe SISRFormat -> SRG -> String prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr) where xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $ - [meta "description" + [meta "description" ("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."), meta "generator" "Grammatical Framework"] - ++ map ruleToXML (srgRules srg) + ++ map ruleToXML (srgRules srg) ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts) where pub = if isExternalCat srg cat then [("scope","public")] else [] - prRhs rhss = [oneOf (map (mkProd sisr) rhss)] + prRhs rhss = [oneOf (map (mkProd sisr) rhss)] mkProd :: Maybe SISRFormat -> SRGAlt -> XML mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf) @@ -50,9 +50,9 @@ mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf) mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML mkItem sisr cn = f - where + where f (REUnion []) = ETag "ruleref" [("special","VOID")] - f (REUnion xs) + f (REUnion xs) | not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)] | otherwise = oneOf (map f xs) where (es,nes) = partition isEpsilon xs @@ -62,7 +62,7 @@ mkItem sisr cn = f f (RESymbol s) = symItem sisr cn s symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML -symItem sisr cn (NonTerminal n@(c,_)) = +symItem sisr cn (NonTerminal n@(c,_)) = Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n) symItem _ _ (Terminal t) = Tag "item" [] [Data (showToken t)] @@ -81,12 +81,12 @@ oneOf = Tag "one-of" [] grammar :: Maybe SISRFormat -> String -- ^ root -> Maybe String -- ^language - -> [XML] -> XML -grammar sisr root ml = + -> [XML] -> XML +grammar sisr root ml = Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"), - ("version","1.0"), - ("mode","voice"), - ("root",root)] + ("version","1.0"), + ("mode","voice"), + ("root",root)] ++ (if isJust sisr then [("tag-format","semantics/1.0")] else []) ++ maybe [] (\l -> [("xml:lang", l)]) ml @@ -94,7 +94,7 @@ meta :: String -> String -> XML meta n c = ETag "meta" [("name",n),("content",c)] optimizeSRGS :: XML -> XML -optimizeSRGS = bottomUpXML f +optimizeSRGS = bottomUpXML f where f (Tag "item" [] [x@(Tag "item" _ _)]) = x f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs diff --git a/src/compiler/GF/Text/Transliterations.hs b/src/compiler/GF/Text/Transliterations.hs index 9b1b6e151..8dbc02823 100644 --- a/src/compiler/GF/Text/Transliterations.hs +++ b/src/compiler/GF/Text/Transliterations.hs @@ -17,7 +17,7 @@ import qualified Data.Map as Map -- to add a new one: define the Unicode range and the corresponding ASCII strings, -- which may be one or more characters long --- conventions to be followed: +-- conventions to be followed: -- each character is either [letter] or [letter+nonletters] -- when using a sparse range of unicodes, mark missing codes as "-" in transliterations -- characters can be invisible: ignored in translation to unicode @@ -33,7 +33,7 @@ transliterateWithFile name src isFrom = (if isFrom then appTransFromUnicode else appTransToUnicode) (getTransliterationFile name src) transliteration :: String -> Maybe Transliteration -transliteration s = Map.lookup s allTransliterations +transliteration s = Map.lookup s allTransliterations allTransliterations = Map.fromList [ ("amharic",transAmharic), @@ -67,25 +67,25 @@ data Transliteration = Trans { } appTransToUnicode :: Transliteration -> String -> String -appTransToUnicode trans = +appTransToUnicode trans = concat . map (\c -> maybe c (return . toEnum) $ Map.lookup c (trans_to_unicode trans) - ) . - filter (flip notElem (invisible_chars trans)) . + ) . + filter (flip notElem (invisible_chars trans)) . unchar appTransFromUnicode :: Transliteration -> String -> String -appTransFromUnicode trans = +appTransFromUnicode trans = concat . - map (\c -> maybe [toEnum c] id $ + map (\c -> maybe [toEnum c] id $ Map.lookup c (trans_from_unicode trans) - ) . + ) . map fromEnum mkTransliteration :: String -> [String] -> [Int] -> Transliteration -mkTransliteration name ts us = +mkTransliteration name ts us = Trans (Map.fromList (tzip ts us)) (Map.fromList (uzip us ts)) [] name where tzip ts us = [(t,u) | (t,u) <- zip ts us, t /= "-"] @@ -102,7 +102,7 @@ getTransliterationFile name = uncurry (mkTransliteration name) . codes unchar :: String -> [String] unchar s = case s of - c:d:cs + c:d:cs | isAlpha d -> [c] : unchar (d:cs) | isSpace d -> [c]:[d]: unchar cs | otherwise -> let (ds,cs2) = break (\x -> isAlpha x || isSpace x) cs in @@ -122,8 +122,8 @@ transThai = mkTransliteration "Thai" allTrans allCodes where allCodes = [0x0e00 .. 0x0e7f] transDevanagari :: Transliteration -transDevanagari = - (mkTransliteration "Devanagari" +transDevanagari = + (mkTransliteration "Devanagari" allTransUrduHindi allCodes){invisible_chars = ["a"]} where allCodes = [0x0900 .. 0x095f] ++ [0x0966 .. 0x096f] @@ -136,13 +136,13 @@ allTransUrduHindi = words $ "- - - - - - - - q x g. z R R' f - " ++ "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " - + transUrdu :: Transliteration -transUrdu = +transUrdu = (mkTransliteration "Urdu" allTrans allCodes) where - allCodes = [0x0622 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641,0x0642] ++ [0x06A9] ++ [0x0644 .. 0x0648] ++ + allCodes = [0x0622 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641,0x0642] ++ [0x06A9] ++ [0x0644 .. 0x0648] ++ [0x0654,0x0658,0x0679,0x067e,0x0686,0x0688,0x0691,0x0698,0x06af,0x06c1,0x06c3,0x06cc,0x06ba,0x06be,0x06d2] ++ - [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4] + [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4] allTrans = words $ "A - w^ - y^ a b - t C j H K d " ++ -- 0622 - 062f "Z r z s X S Z- t- z- e G " ++ -- 0630 - 063a @@ -151,22 +151,22 @@ transUrdu = "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " ++ "? ." transSindhi :: Transliteration -transSindhi = +transSindhi = (mkTransliteration "Sindhi" allTrans allCodes) where allCodes = [0x062e] ++ [0x0627 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641 .. 0x0648] ++ [0x067a,0x067b,0x067d,0x067e,0x067f] ++ [0x0680 .. 0x068f] ++ [0x0699,0x0918,0x06a6,0x061d,0x06a9,0x06af,0x06b3,0x06bb,0x06be,0x06f6,0x064a,0x06b1, 0x06aa, 0x06fd, 0x06fe] ++ - [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4] + [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4] allTrans = words $ "K a b - t C j H - d " ++ -- 0626 - 062f "Z r z s X S Z- t- z- e G " ++ -- 0630 - 063a "f q - L m n - W " ++ -- 0641 - 0648 "T! B T p T' " ++ -- 067a,067b,067d,067e,067f "B' - - Y' J' - c c' - - d! - d' D - D' " ++ -- 0680 - 068f - "R - F' - k' g G' t' h' e' y c! k A M " ++ -- 0699, 0918, 06a6, 061d, 06a9,06af,06b3,06bb,06be,06f6,06cc,06b1 + "R - F' - k' g G' t' h' e' y c! k A M " ++ -- 0699, 0918, 06a6, 061d, 06a9,06af,06b3,06bb,06be,06f6,06cc,06b1 "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " ++ "? ." - + transArabic :: Transliteration transArabic = mkTransliteration "Arabic" allTrans allCodes where @@ -175,8 +175,8 @@ transArabic = mkTransliteration "Arabic" allTrans allCodes where "W r z s C S D T Z c G " ++ -- 0630 - 063a " f q k l m n h w y. y a. u. i. a u " ++ -- 0641 - 064f "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657 - "A* q?" -- 0671 (used by AED) - allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ + "A* q?" -- 0671 (used by AED) + allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ [0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x0671,0x061f] @@ -193,16 +193,16 @@ transPersian = (mkTransliteration "Persian/Farsi" allTrans allCodes) " V A: A? w? A- y? A b t. t t- j H K d " ++ -- 0621 - 062f "W r z s C S D T Z c G " ++ -- 0630 - 063a " f q - l m n h v - y. a. u. i. a u " ++ -- 0640 - 064f - "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657 + "i v2 o a: V+ V- i: a+ " ++ -- 0650 - 0657 "p c^ J k g y q? Z0" - allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ - [0x0641..0x064f] ++ [0x0650..0x0657] ++ + allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ + [0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x067e,0x0686,0x0698,0x06a9,0x06af,0x06cc,0x061f,0x200c] transNepali :: Transliteration transNepali = mkTransliteration "Nepali" allTrans allCodes where allTrans = words $ - "z+ z= " ++ + "z+ z= " ++ "- V M h: - H A i: I: f F Z - - - e: " ++ "E: - - O W k K g G n: C c j J Y q " ++ "Q x X N t T d D n - p P b B m y " ++ @@ -241,7 +241,7 @@ transGreek = mkTransliteration "modern Greek" allTrans allCodes where "i= A B G D E Z H V I K L M N X O " ++ "P R - S T Y F C Q W I- Y- a' e' h' i' " ++ "y= a b g d e z h v i k l m n x o " ++ - "p r s* s t y f c q w i- y- o' y' w' - " + "p r s* s t y f c q w i- y- o' y' w' - " allCodes = [0x0380 .. 0x03cf] transAncientGreek :: Transliteration @@ -261,32 +261,32 @@ transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where "y) y( y)` y(` y)' y(' y)~ y(~ - Y( - Y(` - Y(' - Y(~ " ++ "w) w( w)` w(` w)' w(' w)~ w(~ W) W( W)` W(` W)' W(' W)~ W(~ " ++ "a` a' e` e' h` h' i` i' o` o' y` y' w` w' - - " ++ - "a|) a|( a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80- - "h|) h|( h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90- - "w|) w|( w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0- + "a|) a|( a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80- + "h|) h|( h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90- + "w|) w|( w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0- "a. a_ a|` a| a|' - a~ a|~ - - - - - - - - " ++ -- 1fb0- "- - h|` h| h|' - h~ h|~ - - - - - - - - " ++ -- 1fc0- "i. i_ i=` i=' - - i~ i=~ - - - - - - - - " ++ -- 1fd0- - "y. y_ y=` y=' r) r( y~ y=~ - - - - - - - - " ++ -- 1fe0- + "y. y_ y=` y=' r) r( y~ y=~ - - - - - - - - " ++ -- 1fe0- "- - w|` w| w|' - w~ w|~ - - - - - - - - " ++ -- 1ff0- -- HL, Private Use Area Code Points (New Athena Unicode, Cardo, ALPHABETUM, Antioch) -- see: http://apagreekkeys.org/technicalDetails.html -- GreekKeys Support by Donald Mastronarde - "- - - - - - - - - e. o. R) Y) Y)` Y)' Y)~ " ++ -- e1a0-e1af + "- - - - - - - - - e. o. R) Y) Y)` Y)' Y)~ " ++ -- e1a0-e1af "e~ e)~ e(~ e_ e_' e_` e_) e_( e_)` e_(` e_)' e_(' E)~ E(~ E_ E. " ++ -- e1b0-e1bf "o~ o)~ o(~ o_ o_' o_` o_) o_( o_)` o_(` o_)' o_(' O)~ O(~ O_ O. " ++ -- e1c0-e1cf - "a_` - a_~ a_)` a_(` a_)~ a_(~ - a.` a.) a.)` a.(' a.(` - - - " ++ -- eaf0-eaff - "a_' - - - a_) a_( - a_)' - a_(' a.' a.( a.)' - - - " ++ -- eb00-eb0f + "a_` - a_~ a_)` a_(` a_)~ a_(~ - a.` a.) a.)` a.(' a.(` - - - " ++ -- eaf0-eaff + "a_' - - - a_) a_( - a_)' - a_(' a.' a.( a.)' - - - " ++ -- eb00-eb0f "e_)~ e_(~ - - - - - e_~ - - - - - - - - " ++ -- eb20-eb2f - "- - - - - - i_~ - i_` i_' - - i_) i_)' i_( i_(' " ++ -- eb30-eb3f + "- - - - - - i_~ - i_` i_' - - i_) i_)' i_( i_(' " ++ -- eb30-eb3f "i.' i.) i.)' i.( i.` i.)` - i.(' i.(` - - - - - - - " ++ -- eb40-eb4f "- - - - i_)` i_(` - i_)~ i_(~ - o_~ o_)~ o_(~ - - - " ++ -- eb50-eb5f "y_` " ++ -- eb6f "y_~ y_)` - - - y_(` - y_)~ y_(~ - y_' - - y_) y_( y_)' " ++ -- eb70-eb7f "y_(' y.' y.( y.` y.) y.)' - - y.)` y.(' y.(` - - - - - " -- eb80-eb8f - allCodes = -- [0x00B0 .. 0x00Bf] - [0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff] - ++ [0xe1a0 .. 0xe1af] + allCodes = -- [0x00B0 .. 0x00Bf] + [0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff] + ++ [0xe1a0 .. 0xe1af] ++ [0xe1b0 .. 0xe1bf] ++ [0xe1c0 .. 0xe1cf] ++ [0xeaf0 .. 0xeaff] @@ -297,36 +297,34 @@ transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where ++ [0xeb50 .. 0xeb5f] ++ [0xeb6f] ++ [0xeb70 .. 0xeb7f] ++ [0xeb80 .. 0xeb8f] - -transAmharic :: Transliteration + +transAmharic :: Transliteration transAmharic = mkTransliteration "Amharic" allTrans allCodes where - -allTrans = words $ - - " h. h- h' h( h) h h? h* l. l- l' l( l) l l? l* "++ - " H. H- H' H( H) H H? H* m. m- m' m( m) m m? m* "++ - " s. s- s' s( s) s s? s* r. r- r' r( r) r r? r* "++ - " - - - - - - - - x. x- x' x( x) x x? x* "++ - " q. q- q' q( q) q q? q* - - - - - - - - "++ - " - - - - - - - - - - - - - - - - "++ - " b. b- b' b( b) b b? b* v. v- v' v( v) v v? v* "++ - " t. t- t' t( t) t t? t* c. c- c' c( c) c c? c* "++ - " X. X- X' X( X) X X? - - - - X* - - - - "++ - " n. n- n' n( n) n n? n* N. N- N' N( N) N N? N* "++ - " a u i A E e o e* k. k- k' k( k) k k? - "++ - " - - - k* - - - - - - - - - - - - "++ - " - - - - - - - - w. w- w' w( w) w w? w* "++ - " - - - - - - - - z. z- z' z( z) z z? z* "++ - " Z. Z- Z' Z( Z) Z Z? Z* y. y- y' y( y) y y? y* "++ - " d. d- d' d( d) d d? d* - - - - - - - - "++ - " j. j- j' j( j) j j? j* g. g- g' g( g) g g? - "++ - " - - - g* - - - - - - - - - - - - "++ - " T. T- T' T( T) T T? T* C. C- C' C( C) C C? C* "++ - " P. P- P' P( P) P P? P* S. S- S' S( S) S S? S* "++ - " - - - - - - - - f. f- f' f( f) f f? f*"++ - " p. p- p' p( p) p p? p*" -allCodes = [0x1200..0x1357] - + allTrans = words $ + " h. h- h' h( h) h h? h* l. l- l' l( l) l l? l* "++ + " H. H- H' H( H) H H? H* m. m- m' m( m) m m? m* "++ + " s. s- s' s( s) s s? s* r. r- r' r( r) r r? r* "++ + " - - - - - - - - x. x- x' x( x) x x? x* "++ + " q. q- q' q( q) q q? q* - - - - - - - - "++ + " - - - - - - - - - - - - - - - - "++ + " b. b- b' b( b) b b? b* v. v- v' v( v) v v? v* "++ + " t. t- t' t( t) t t? t* c. c- c' c( c) c c? c* "++ + " X. X- X' X( X) X X? - - - - X* - - - - "++ + " n. n- n' n( n) n n? n* N. N- N' N( N) N N? N* "++ + " a u i A E e o e* k. k- k' k( k) k k? - "++ + " - - - k* - - - - - - - - - - - - "++ + " - - - - - - - - w. w- w' w( w) w w? w* "++ + " - - - - - - - - z. z- z' z( z) z z? z* "++ + " Z. Z- Z' Z( Z) Z Z? Z* y. y- y' y( y) y y? y* "++ + " d. d- d' d( d) d d? d* - - - - - - - - "++ + " j. j- j' j( j) j j? j* g. g- g' g( g) g g? - "++ + " - - - g* - - - - - - - - - - - - "++ + " T. T- T' T( T) T T? T* C. C- C' C( C) C C? C* "++ + " P. P- P' P( P) P P? P* S. S- S' S( S) S S? S* "++ + " - - - - - - - - f. f- f' f( f) f f? f*"++ + " p. p- p' p( p) p p? p*" + allCodes = [0x1200..0x1357] + -- by Prasad 31/5/2013 transSanskrit :: Transliteration transSanskrit = (mkTransliteration "Sanskrit" allTrans allCodes) {invisible_chars = ["a"]} where diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal index eb1e3c708..1d5f61991 100644 --- a/src/runtime/haskell-bind/pgf2.cabal +++ b/src/runtime/haskell-bind/pgf2.cabal @@ -26,7 +26,7 @@ library PGF2.Expr, PGF2.Type build-depends: - base >= 4.9.1 && <4.15, + base >= 4.9.1 && < 4.15, containers >= 0.5.7 && < 0.7, pretty >= 1.1.3 && < 1.2 default-language: Haskell2010 diff --git a/src/runtime/haskell/pgf.cabal b/src/runtime/haskell/pgf.cabal index 56c1ca04a..ab54be441 100644 --- a/src/runtime/haskell/pgf.cabal +++ b/src/runtime/haskell/pgf.cabal @@ -14,7 +14,7 @@ tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4 library default-language: Haskell2010 build-depends: - base >= 4.9.1 && <4.15, + base >= 4.9.1 && < 4.15, array >= 0.5.1 && < 0.6, containers >= 0.5.7 && < 0.7, bytestring >= 0.10.8 && < 0.11, -- cgit v1.2.3