summaryrefslogtreecommitdiff
path: root/src/GF/Grammar
diff options
context:
space:
mode:
authorkrasimir <krasimir@chalmers.se>2009-12-13 18:50:29 +0000
committerkrasimir <krasimir@chalmers.se>2009-12-13 18:50:29 +0000
commitf85232947e74ee7ef8c7b0ad2338212e7e68f1be (patch)
tree667b886a5e3a4b026a63d4e3597f32497d824761 /src/GF/Grammar
parentd88a865faff59c98fc91556ff8700b10ee5f2df8 (diff)
reorganize the directories under src, and rescue the JavaScript interpreter from deprecated
Diffstat (limited to 'src/GF/Grammar')
-rw-r--r--src/GF/Grammar/Binary.hs261
-rw-r--r--src/GF/Grammar/CF.hs128
-rw-r--r--src/GF/Grammar/Grammar.hs230
-rw-r--r--src/GF/Grammar/Lexer.hs478
-rw-r--r--src/GF/Grammar/Lexer.x272
-rw-r--r--src/GF/Grammar/Lockfield.hs52
-rw-r--r--src/GF/Grammar/Lookup.hs188
-rw-r--r--src/GF/Grammar/MMacros.hs279
-rw-r--r--src/GF/Grammar/Macros.hs627
-rw-r--r--src/GF/Grammar/Parser.y739
-rw-r--r--src/GF/Grammar/PatternMatch.hs165
-rw-r--r--src/GF/Grammar/Predef.hs180
-rw-r--r--src/GF/Grammar/Printer.hs317
-rw-r--r--src/GF/Grammar/Unify.hs97
-rw-r--r--src/GF/Grammar/Values.hs96
15 files changed, 0 insertions, 4109 deletions
diff --git a/src/GF/Grammar/Binary.hs b/src/GF/Grammar/Binary.hs
deleted file mode 100644
index fbad5ac7e..000000000
--- a/src/GF/Grammar/Binary.hs
+++ /dev/null
@@ -1,261 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : GF.Grammar.Binary
--- Maintainer : Krasimir Angelov
--- Stability : (stable)
--- Portability : (portable)
---
------------------------------------------------------------------------------
-
-module GF.Grammar.Binary where
-
-import Data.Binary
-import qualified Data.Map as Map
-import qualified Data.ByteString.Char8 as BS
-
-import GF.Data.Operations
-import GF.Infra.Ident
-import GF.Infra.Option
-import GF.Infra.Modules
-import GF.Grammar.Grammar
-
-instance Binary Ident where
- put id = put (ident2bs id)
- get = do bs <- get
- if bs == BS.pack "_"
- then return identW
- else return (identC bs)
-
-instance (Ord i, Binary i, Binary a) => Binary (MGrammar i a) where
- put (MGrammar ms) = put ms
- get = fmap MGrammar get
-
-instance (Ord i, Binary i, Binary a) => Binary (ModInfo i a) where
- put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi,positions mi)
- get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments,positions) <- get
- return (ModInfo mtype mstatus flags extend mwith opens med jments positions)
-
-instance (Binary i) => Binary (ModuleType i) where
- put MTAbstract = putWord8 0
- put MTResource = putWord8 2
- put (MTConcrete i) = putWord8 3 >> put i
- put MTInterface = putWord8 4
- put (MTInstance i) = putWord8 5 >> put i
- get = do tag <- getWord8
- case tag of
- 0 -> return MTAbstract
- 2 -> return MTResource
- 3 -> get >>= return . MTConcrete
- 4 -> return MTInterface
- 5 -> get >>= return . MTInstance
- _ -> decodingError
-
-instance (Binary i) => Binary (MInclude i) where
- put MIAll = putWord8 0
- put (MIOnly xs) = putWord8 1 >> put xs
- put (MIExcept xs) = putWord8 2 >> put xs
- get = do tag <- getWord8
- case tag of
- 0 -> return MIAll
- 1 -> fmap MIOnly get
- 2 -> fmap MIExcept get
- _ -> decodingError
-
-instance Binary i => Binary (OpenSpec i) where
- put (OSimple i) = putWord8 0 >> put i
- put (OQualif i j) = putWord8 1 >> put (i,j)
- get = do tag <- getWord8
- case tag of
- 0 -> get >>= return . OSimple
- 1 -> get >>= \(i,j) -> return (OQualif i j)
- _ -> decodingError
-
-instance Binary ModuleStatus where
- put MSComplete = putWord8 0
- put MSIncomplete = putWord8 1
- get = do tag <- getWord8
- case tag of
- 0 -> return MSComplete
- 1 -> return MSIncomplete
- _ -> decodingError
-
-instance Binary Options where
- put = put . optionsGFO
- get = do opts <- get
- case parseModuleOptions ["--" ++ flag ++ "=" ++ value | (flag,value) <- opts] of
- Ok x -> return x
- Bad msg -> fail msg
-
-instance Binary Info where
- put (AbsCat x y) = putWord8 0 >> put (x,y)
- put (AbsFun x y z) = putWord8 1 >> put (x,y,z)
- put (ResParam x y) = putWord8 2 >> put (x,y)
- put (ResValue x) = putWord8 3 >> put x
- put (ResOper x y) = putWord8 4 >> put (x,y)
- put (ResOverload x y)= putWord8 5 >> put (x,y)
- put (CncCat x y z) = putWord8 6 >> put (x,y,z)
- put (CncFun x y z) = putWord8 7 >> put (x,y,z)
- put (AnyInd x y) = putWord8 8 >> put (x,y)
- get = do tag <- getWord8
- case tag of
- 0 -> get >>= \(x,y) -> return (AbsCat x y)
- 1 -> get >>= \(x,y,z) -> return (AbsFun x y z)
- 2 -> get >>= \(x,y) -> return (ResParam x y)
- 3 -> get >>= \x -> return (ResValue x)
- 4 -> get >>= \(x,y) -> return (ResOper x y)
- 5 -> get >>= \(x,y) -> return (ResOverload x y)
- 6 -> get >>= \(x,y,z) -> return (CncCat x y z)
- 7 -> get >>= \(x,y,z) -> return (CncFun x y z)
- 8 -> get >>= \(x,y) -> return (AnyInd x y)
- _ -> decodingError
-
-instance Binary BindType where
- put Explicit = putWord8 0
- put Implicit = putWord8 1
- get = do tag <- getWord8
- case tag of
- 0 -> return Explicit
- 1 -> return Implicit
- _ -> decodingError
-
-instance Binary Term where
- put (Vr x) = putWord8 0 >> put x
- put (Cn x) = putWord8 1 >> put x
- put (Con x) = putWord8 2 >> put x
- put (Sort x) = putWord8 3 >> put x
- put (EInt x) = putWord8 4 >> put x
- put (EFloat x) = putWord8 5 >> put x
- put (K x) = putWord8 6 >> put x
- put (Empty) = putWord8 7
- put (App x y) = putWord8 8 >> put (x,y)
- put (Abs x y z) = putWord8 9 >> put (x,y,z)
- put (Meta x) = putWord8 10 >> put x
- put (Prod w x y z)= putWord8 11 >> put (w,x,y,z)
- put (Typed x y) = putWord8 12 >> put (x,y)
- put (Example x y) = putWord8 13 >> put (x,y)
- put (RecType x) = putWord8 14 >> put x
- put (R x) = putWord8 15 >> put x
- put (P x y) = putWord8 16 >> put (x,y)
- put (ExtR x y) = putWord8 17 >> put (x,y)
- put (Table x y) = putWord8 18 >> put (x,y)
- put (T x y) = putWord8 19 >> put (x,y)
- put (V x y) = putWord8 20 >> put (x,y)
- put (S x y) = putWord8 21 >> put (x,y)
- put (Let x y) = putWord8 22 >> put (x,y)
- put (Q x y) = putWord8 23 >> put (x,y)
- put (QC x y) = putWord8 24 >> put (x,y)
- put (C x y) = putWord8 25 >> put (x,y)
- put (Glue x y) = putWord8 26 >> put (x,y)
- put (EPatt x) = putWord8 27 >> put x
- put (EPattType x) = putWord8 28 >> put x
- put (FV x) = putWord8 29 >> put x
- put (Alts x) = putWord8 30 >> put x
- put (Strs x) = putWord8 31 >> put x
- put (ELin x y) = putWord8 32 >> put (x,y)
-
- get = do tag <- getWord8
- case tag of
- 0 -> get >>= \x -> return (Vr x)
- 1 -> get >>= \x -> return (Cn x)
- 2 -> get >>= \x -> return (Con x)
- 3 -> get >>= \x -> return (Sort x)
- 4 -> get >>= \x -> return (EInt x)
- 5 -> get >>= \x -> return (EFloat x)
- 6 -> get >>= \x -> return (K x)
- 7 -> return (Empty)
- 8 -> get >>= \(x,y) -> return (App x y)
- 9 -> get >>= \(x,y,z) -> return (Abs x y z)
- 10 -> get >>= \x -> return (Meta x)
- 11 -> get >>= \(w,x,y,z)->return (Prod w x y z)
- 12 -> get >>= \(x,y) -> return (Typed x y)
- 13 -> get >>= \(x,y) -> return (Example x y)
- 14 -> get >>= \x -> return (RecType x)
- 15 -> get >>= \x -> return (R x)
- 16 -> get >>= \(x,y) -> return (P x y)
- 17 -> get >>= \(x,y) -> return (ExtR x y)
- 18 -> get >>= \(x,y) -> return (Table x y)
- 19 -> get >>= \(x,y) -> return (T x y)
- 20 -> get >>= \(x,y) -> return (V x y)
- 21 -> get >>= \(x,y) -> return (S x y)
- 22 -> get >>= \(x,y) -> return (Let x y)
- 23 -> get >>= \(x,y) -> return (Q x y)
- 24 -> get >>= \(x,y) -> return (QC x y)
- 25 -> get >>= \(x,y) -> return (C x y)
- 26 -> get >>= \(x,y) -> return (Glue x y)
- 27 -> get >>= \x -> return (EPatt x)
- 28 -> get >>= \x -> return (EPattType x)
- 29 -> get >>= \x -> return (FV x)
- 30 -> get >>= \x -> return (Alts x)
- 31 -> get >>= \x -> return (Strs x)
- 32 -> get >>= \(x,y) -> return (ELin x y)
- _ -> decodingError
-
-instance Binary Patt where
- put (PC x y) = putWord8 0 >> put (x,y)
- put (PP x y z) = putWord8 1 >> put (x,y,z)
- put (PV x) = putWord8 2 >> put x
- put (PW) = putWord8 3
- put (PR x) = putWord8 4 >> put x
- put (PString x) = putWord8 5 >> put x
- put (PInt x) = putWord8 6 >> put x
- put (PFloat x) = putWord8 7 >> put x
- put (PT x y) = putWord8 8 >> put (x,y)
- put (PAs x y) = putWord8 10 >> put (x,y)
- put (PNeg x) = putWord8 11 >> put x
- put (PAlt x y) = putWord8 12 >> put (x,y)
- put (PSeq x y) = putWord8 13 >> put (x,y)
- put (PRep x) = putWord8 14 >> put x
- put (PChar) = putWord8 15
- put (PChars x) = putWord8 16 >> put x
- put (PMacro x) = putWord8 17 >> put x
- put (PM x y) = putWord8 18 >> put (x,y)
- get = do tag <- getWord8
- case tag of
- 0 -> get >>= \(x,y) -> return (PC x y)
- 1 -> get >>= \(x,y,z) -> return (PP x y z)
- 2 -> get >>= \x -> return (PV x)
- 3 -> return (PW)
- 4 -> get >>= \x -> return (PR x)
- 5 -> get >>= \x -> return (PString x)
- 6 -> get >>= \x -> return (PInt x)
- 7 -> get >>= \x -> return (PFloat x)
- 8 -> get >>= \(x,y) -> return (PT x y)
- 10 -> get >>= \(x,y) -> return (PAs x y)
- 11 -> get >>= \x -> return (PNeg x)
- 12 -> get >>= \(x,y) -> return (PAlt x y)
- 13 -> get >>= \(x,y) -> return (PSeq x y)
- 14 -> get >>= \x -> return (PRep x)
- 15 -> return (PChar)
- 16 -> get >>= \x -> return (PChars x)
- 17 -> get >>= \x -> return (PMacro x)
- 18 -> get >>= \(x,y) -> return (PM x y)
- _ -> decodingError
-
-instance Binary TInfo where
- put TRaw = putWord8 0
- put (TTyped t) = putWord8 1 >> put t
- put (TComp t) = putWord8 2 >> put t
- put (TWild t) = putWord8 3 >> put t
- get = do tag <- getWord8
- case tag of
- 0 -> return TRaw
- 1 -> fmap TTyped get
- 2 -> fmap TComp get
- 3 -> fmap TWild get
- _ -> decodingError
-
-instance Binary Label where
- put (LIdent bs) = putWord8 0 >> put bs
- put (LVar i) = putWord8 1 >> put i
- get = do tag <- getWord8
- case tag of
- 0 -> fmap LIdent get
- 1 -> fmap LVar get
- _ -> decodingError
-
-decodeModHeader :: FilePath -> IO SourceModule
-decodeModHeader fpath = do
- (m,mtype,mstatus,flags,extend,mwith,opens,med) <- decodeFile fpath
- return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty Map.empty)
-
-decodingError = fail "This GFO file was compiled with different version of GF"
diff --git a/src/GF/Grammar/CF.hs b/src/GF/Grammar/CF.hs
deleted file mode 100644
index a1d716994..000000000
--- a/src/GF/Grammar/CF.hs
+++ /dev/null
@@ -1,128 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : CF
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/15 17:56:13 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.13 $
---
--- parsing CF grammars and converting them to GF
------------------------------------------------------------------------------
-
-module GF.Grammar.CF (getCF) where
-
-import GF.Grammar.Grammar
-import GF.Grammar.Macros
-import GF.Infra.Ident
-import GF.Infra.Modules
-import GF.Infra.Option
-
-import GF.Data.Operations
-
-import Data.Char
-import Data.List
-import qualified Data.ByteString.Char8 as BS
-
-getCF :: String -> String -> Err SourceGrammar
-getCF name = fmap (cf2gf name) . pCF
-
----------------------
--- the parser -------
----------------------
-
-pCF :: String -> Err CF
-pCF s = do
- rules <- mapM getCFRule $ filter isRule $ lines s
- return $ concat rules
- where
- isRule line = case dropWhile isSpace line of
- '-':'-':_ -> False
- _ -> not $ all isSpace line
-
--- rules have an amazingly easy parser, if we use the format
--- fun. C -> item1 item2 ... where unquoted items are treated as cats
--- Actually would be nice to add profiles to this.
-
-getCFRule :: String -> Err [CFRule]
-getCFRule s = getcf (wrds s) where
- getcf ws = case ws of
- fun : cat : a : its | isArrow a ->
- Ok [(init fun, (cat, map mkIt its))]
- cat : a : its | isArrow a ->
- Ok [(mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
- _ -> Bad (" invalid rule:" +++ s)
- isArrow a = elem a ["->", "::="]
- mkIt w = case w of
- ('"':w@(_:_)) -> Right (init w)
- _ -> Left w
- chunk its = case its of
- [] -> [[]]
- _ -> chunks "|" its
- mkFun cat its = case its of
- [] -> cat ++ "_"
- _ -> concat $ intersperse "_" (cat : map clean its) -- CLE style
- clean = filter isAlphaNum -- to form valid identifiers
- wrds = takeWhile (/= ";") . words -- to permit semicolon in the end
-
-type CF = [CFRule]
-
-type CFRule = (CFFun, (CFCat, [CFItem]))
-
-type CFItem = Either CFCat String
-
-type CFCat = String
-type CFFun = String
-
---------------------------
--- the compiler ----------
---------------------------
-
-cf2gf :: String -> CF -> SourceGrammar
-cf2gf name cf = MGrammar [
- (aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat}))
- (emptyModInfo{mtype = MTAbstract, jments = abs})),
- (cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc})
- ]
- where
- (abs,cnc,cat) = cf2grammar cf
- aname = identS $ name ++ "Abs"
- cname = identS name
-
-
-cf2grammar :: CF -> (BinTree Ident Info, BinTree Ident Info, String)
-cf2grammar rules = (buildTree abs, buildTree conc, cat) where
- abs = cats ++ funs
- conc = lincats ++ lins
- cat = case rules of
- (_,(c,_)):_ -> c -- the value category of the first rule
- _ -> error "empty CF"
- cats = [(cat, AbsCat (Just []) (Just [])) |
- cat <- nub (concat (map cf2cat rules))] ----notPredef cat
- lincats = [(cat, CncCat (Just defLinType) Nothing Nothing) | (cat,AbsCat _ _) <- cats]
- (funs,lins) = unzip (map cf2rule rules)
-
-cf2cat :: CFRule -> [Ident]
-cf2cat (_,(cat, items)) = map identS $ cat : [c | Left c <- items]
-
-cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
-cf2rule (fun, (cat, items)) = (def,ldef) where
- f = identS fun
- def = (f, AbsFun (Just (mkProd args' (Cn (identS cat)) [])) Nothing Nothing)
- args0 = zip (map (identS . ("x" ++) . show) [0..]) items
- args = [((Explicit,v), Cn (identS c)) | (v, Left c) <- args0]
- args' = [(Explicit,identS "_", Cn (identS c)) | (_, Left c) <- args0]
- ldef = (f, CncFun
- Nothing
- (Just (mkAbs (map fst args)
- (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)])))
- Nothing)
- mkIt (v, Left _) = P (Vr v) theLinLabel
- mkIt (_, Right a) = K a
- foldconcat [] = K ""
- foldconcat tt = foldr1 C tt
-
-identS = identC . BS.pack
-
diff --git a/src/GF/Grammar/Grammar.hs b/src/GF/Grammar/Grammar.hs
deleted file mode 100644
index 8d1468d9d..000000000
--- a/src/GF/Grammar/Grammar.hs
+++ /dev/null
@@ -1,230 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Grammar
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:20 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.8 $
---
--- GF source abstract syntax used internally in compilation.
---
--- AR 23\/1\/2000 -- 30\/5\/2001 -- 4\/5\/2003
------------------------------------------------------------------------------
-
-module GF.Grammar.Grammar (SourceGrammar,
- emptySourceGrammar,
- SourceModInfo,
- SourceModule,
- mapSourceModule,
- Info(..),
- Type,
- Cat,
- Fun,
- QIdent,
- BindType(..),
- Term(..),
- Patt(..),
- TInfo(..),
- Label(..),
- MetaId,
- Hypo,
- Context,
- Equation,
- Labelling,
- Assign,
- Case,
- LocalDef,
- Param,
- Altern,
- Substitution,
- varLabel, tupleLabel, linLabel, theLinLabel,
- ident2label, label2ident
- ) where
-
-import GF.Infra.Ident
-import GF.Infra.Option ---
-import GF.Infra.Modules
-
-import GF.Data.Operations
-
-import qualified Data.ByteString.Char8 as BS
-
--- | grammar as presented to the compiler
-type SourceGrammar = MGrammar Ident Info
-
-emptySourceGrammar = MGrammar []
-
-type SourceModInfo = ModInfo Ident Info
-
-type SourceModule = (Ident, SourceModInfo)
-
-mapSourceModule :: (SourceModInfo -> SourceModInfo) -> (SourceModule -> SourceModule)
-mapSourceModule f (i,mi) = (i, f mi)
-
--- | the constructors are judgements in
---
--- - abstract syntax (/ABS/)
---
--- - resource (/RES/)
---
--- - concrete syntax (/CNC/)
---
--- and indirection to module (/INDIR/)
-data Info =
--- judgements in abstract syntax
- AbsCat (Maybe Context) (Maybe [Term]) -- ^ (/ABS/) the second parameter is list of constructors - must be 'Id' or 'QId'
- | AbsFun (Maybe Type) (Maybe Int) (Maybe [Equation]) -- ^ (/ABS/) type, arrity and definition of function
-
--- judgements in resource
- | ResParam (Maybe [Param]) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values
- | ResValue Type -- ^ (/RES/) to mark parameter constructors for lookup
- | ResOper (Maybe Type) (Maybe Term) -- ^ (/RES/)
-
- | ResOverload [Ident] [(Type,Term)] -- ^ (/RES/) idents: modules inherited
-
--- judgements in concrete syntax
- | CncCat (Maybe Type) (Maybe Term) (Maybe Term) -- ^ (/CNC/) lindef ini'zed,
- | CncFun (Maybe (Ident,Context,Type)) (Maybe Term) (Maybe Term) -- ^ (/CNC/) type info added at 'TC'
-
--- indirection to module Ident
- | AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
- deriving Show
-
-type Type = Term
-type Cat = QIdent
-type Fun = QIdent
-
-type QIdent = (Ident,Ident)
-
-data BindType =
- Explicit
- | Implicit
- deriving (Eq,Ord,Show)
-
-data Term =
- Vr Ident -- ^ variable
- | Cn Ident -- ^ constant
- | Con Ident -- ^ constructor
- | Sort Ident -- ^ basic type
- | EInt Integer -- ^ integer literal
- | EFloat Double -- ^ floating point literal
- | K String -- ^ string literal or token: @\"foo\"@
- | Empty -- ^ the empty string @[]@
-
- | App Term Term -- ^ application: @f a@
- | Abs BindType Ident Term -- ^ abstraction: @\x -> b@
- | Meta {-# UNPACK #-} !MetaId -- ^ metavariable: @?i@ (only parsable: ? = ?0)
- | ImplArg Term -- ^ placeholder for implicit argument @{t}@
- | Prod BindType Ident Term Term -- ^ function type: @(x : A) -> B@, @A -> B@, @({x} : A) -> B@
- | Typed Term Term -- ^ type-annotated term
---
--- /below this, the constructors are only for concrete syntax/
- | Example Term String -- ^ example-based term: @in M.C "foo"
- | RecType [Labelling] -- ^ record type: @{ p : A ; ...}@
- | R [Assign] -- ^ record: @{ p = a ; ...}@
- | P Term Label -- ^ projection: @r.p@
- | ExtR Term Term -- ^ extension: @R ** {x : A}@ (both types and terms)
-
- | Table Term Term -- ^ table type: @P => A@
- | T TInfo [Case] -- ^ table: @table {p => c ; ...}@
- | V Type [Term] -- ^ table given as course of values: @table T [c1 ; ... ; cn]@
- | S Term Term -- ^ selection: @t ! p@
-
- | Let LocalDef Term -- ^ local definition: @let {t : T = a} in b@
-
- | Q Ident Ident -- ^ qualified constant from a package
- | QC Ident Ident -- ^ qualified constructor from a package
-
- | C Term Term -- ^ concatenation: @s ++ t@
- | Glue Term Term -- ^ agglutination: @s + t@
-
- | EPatt Patt -- ^ pattern (in macro definition): # p
- | EPattType Term -- ^ pattern type: pattern T
-
- | ELincat Ident Term -- ^ boxed linearization type of Ident
- | ELin Ident Term -- ^ boxed linearization of type Ident
-
- | FV [Term] -- ^ alternatives in free variation: @variants { s ; ... }@
-
- | Alts (Term, [(Term, Term)]) -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
- | Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@
-
- deriving (Show, Eq, Ord)
-
-data Patt =
- PC Ident [Patt] -- ^ constructor pattern: @C p1 ... pn@ @C@
- | PP Ident Ident [Patt] -- ^ package constructor pattern: @P.C p1 ... pn@ @P.C@
- | PV Ident -- ^ variable pattern: @x@
- | PW -- ^ wild card pattern: @_@
- | PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete
- | PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract
- | PInt Integer -- ^ integer literal pattern: @12@ -- only abstract
- | PFloat Double -- ^ float literal pattern: @1.2@ -- only abstract
- | PT Type Patt -- ^ type-annotated pattern
-
- | PAs Ident Patt -- ^ as-pattern: x@p
-
- | PImplArg Patt -- ^ placeholder for pattern for implicit argument @{p}@
-
- -- regular expression patterns
- | PNeg Patt -- ^ negated pattern: -p
- | PAlt Patt Patt -- ^ disjunctive pattern: p1 | p2
- | PSeq Patt Patt -- ^ sequence of token parts: p + q
- | PRep Patt -- ^ repetition of token part: p*
- | PChar -- ^ string of length one: ?
- | PChars [Char] -- ^ character list: ["aeiou"]
- | PMacro Ident -- #p
- | PM Ident Ident -- #m.p
-
- deriving (Show, Eq, Ord)
-
--- | to guide computation and type checking of tables
-data TInfo =
- TRaw -- ^ received from parser; can be anything
- | TTyped Type -- ^ type annontated, but can be anything
- | TComp Type -- ^ expanded
- | TWild Type -- ^ just one wild card pattern, no need to expand
- deriving (Show, Eq, Ord)
-
--- | record label
-data Label =
- LIdent BS.ByteString
- | LVar Int
- deriving (Show, Eq, Ord)
-
-type MetaId = Int
-
-type Hypo = (BindType,Ident,Term) -- (x:A) (_:A) A ({x}:A)
-type Context = [Hypo] -- (x:A)(y:B) (x,y:A) (_,_:A)
-type Equation = ([Patt],Term)
-
-type Labelling = (Label, Term)
-type Assign = (Label, (Maybe Type, Term))
-type Case = (Patt, Term)
-type Cases = ([Patt], Term)
-type LocalDef = (Ident, (Maybe Type, Term))
-
-type Param = (Ident, Context)
-type Altern = (Term, [(Term, Term)])
-
-type Substitution = [(Ident, Term)]
-
-varLabel :: Int -> Label
-varLabel = LVar
-
-tupleLabel, linLabel :: Int -> Label
-tupleLabel i = LIdent $! BS.pack ('p':show i)
-linLabel i = LIdent $! BS.pack ('s':show i)
-
-theLinLabel :: Label
-theLinLabel = LIdent (BS.singleton 's')
-
-ident2label :: Ident -> Label
-ident2label c = LIdent (ident2bs c)
-
-label2ident :: Label -> Ident
-label2ident (LIdent s) = identC s
-label2ident (LVar i) = identC (BS.pack ('$':show i))
diff --git a/src/GF/Grammar/Lexer.hs b/src/GF/Grammar/Lexer.hs
deleted file mode 100644
index 7cacb0588..000000000
--- a/src/GF/Grammar/Lexer.hs
+++ /dev/null
@@ -1,478 +0,0 @@
-{-# OPTIONS -fglasgow-exts -cpp #-}
-{-# LINE 3 "src\GF\Grammar\Lexer.x" #-}
-
-module GF.Grammar.Lexer
- ( Token(..), Posn(..)
- , P, runP, lexer, getPosn, failLoc
- , isReservedWord
- ) where
-
-import GF.Infra.Ident
-import GF.Data.Operations
-import qualified Data.ByteString.Char8 as BS
-import qualified Data.Map as Map
-
-
-#if __GLASGOW_HASKELL__ >= 603
-#include "ghcconfig.h"
-#elif defined(__GLASGOW_HASKELL__)
-#include "config.h"
-#endif
-#if __GLASGOW_HASKELL__ >= 503
-import Data.Array
-import Data.Char (ord)
-import Data.Array.Base (unsafeAt)
-#else
-import Array
-import Char (ord)
-#endif
-#if __GLASGOW_HASKELL__ >= 503
-import GHC.Exts
-#else
-import GlaExts
-#endif
-alex_base :: AlexAddr
-alex_base = AlexA# "\x01\x00\x00\x00\x15\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x18\x00\x00\x00\x19\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x45\x00\x00\x00\x1b\x00\x00\x00\x1c\x00\x00\x00\x1d\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x26\x00\x00\x00\x27\x00\x00\x00\xf5\xff\xff\xff\x16\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2e\x00\x00\x00\x6c\x01\x00\x00\x3c\x02\x00\x00\x00\x00\x00\x00\x17\x01\x00\x00\xe7\x01\x00\x00\xd5\x00\x00\x00\x35\x00\x00\x00\xe7\x00\x00\x00\xf2\x00\x00\x00\x1d\x01\x00\x00\xc2\x01\x00\x00\xcc\x01\x00\x00"#
-
-alex_table :: AlexAddr
-alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0e\x00\x1a\x00\x0e\x00\x0e\x00\x0e\x00\xff\xff\x15\x00\x0e\x00\x0e\x00\x0f\x00\x10\x00\x0e\x00\x05\x00\x0e\x00\x0e\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x0e\x00\x0e\x00\x0e\x00\x12\x00\x0e\x00\x0e\x00\x0e\x00\x04\x00\xff\xff\xff\xff\x02\x00\x02\x00\x09\x00\x09\x00\x09\x00\x0a\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0e\x00\x0e\x00\x0e\x00\x14\x00\x0e\x00\x14\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x11\x00\x0e\x00\xff\xff\x13\x00\xff\xff\x0d\x00\x20\x00\x00\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x00\x00\x00\x00\x09\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0e\x00\x0e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x06\x00\x07\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x1b\x00\xff\xff\x00\x00\x00\x00\x18\x00\x1b\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xff\xff\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x21\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x1c\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\xff\xff\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x1c\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00"#
-
-alex_check :: AlexAddr
-alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2d\x00\x0a\x00\x0a\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2a\x00\x5c\x00\x2b\x00\x27\x00\x3e\x00\x27\x00\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x20\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x2d\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x7d\x00\x7d\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x22\x00\xf7\x00\xff\xff\xff\xff\x5f\x00\x27\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x27\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"#
-
-alex_deflt :: AlexAddr
-alex_deflt = AlexA# "\x17\x00\xff\xff\x03\x00\x03\x00\xff\xff\xff\xff\x0b\x00\xff\xff\x0b\x00\x0b\x00\x0b\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
-
-alex_accept = listArray (0::Int,34) [[],[],[(AlexAccSkip)],[(AlexAccSkip)],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[],[(AlexAcc (alex_action_3))],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[],[],[],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_8))],[],[],[]]
-{-# LINE 42 "src\GF\Grammar\Lexer.x" #-}
-
-
-tok f p s = f s
-
-data Token
- = T_exclmark
- | T_patt
- | T_int_label
- | T_oparen
- | T_cparen
- | T_star
- | T_starstar
- | T_plus
- | T_plusplus
- | T_comma
- | T_minus
- | T_rarrow
- | T_dot
- | T_alt
- | T_colon
- | T_semicolon
- | T_less
- | T_equal
- | T_big_rarrow
- | T_great
- | T_questmark
- | T_obrack
- | T_lam
- | T_lamlam
- | T_cbrack
- | T_ocurly
- | T_bar
- | T_ccurly
- | T_underscore
- | T_at
- | T_PType
- | T_Str
- | T_Strs
- | T_Tok
- | T_Type
- | T_abstract
- | T_case
- | T_cat
- | T_concrete
- | T_data
- | T_def
- | T_flags
- | T_fn
- | T_fun
- | T_in
- | T_incomplete
- | T_instance
- | T_interface
- | T_let
- | T_lin
- | T_lincat
- | T_lindef
- | T_of
- | T_open
- | T_oper
- | T_param
- | T_pattern
- | T_pre
- | T_printname
- | T_resource
- | T_strs
- | T_table
- | T_transfer
- | T_variants
- | T_where
- | T_with
- | T_String String -- string literals
- | T_Integer Integer -- integer literals
- | T_Double Double -- double precision float literals
- | T_LString String
- | T_Ident Ident
- | T_EOF
-
-eitherResIdent :: (BS.ByteString -> Token) -> BS.ByteString -> Token
-eitherResIdent tv s =
- case Map.lookup s resWords of
- Just t -> t
- Nothing -> tv s
-
-isReservedWord :: BS.ByteString -> Bool
-isReservedWord s = Map.member s resWords
-
-resWords = Map.fromList
- [ b "!" T_exclmark
- , b "#" T_patt
- , b "$" T_int_label
- , b "(" T_oparen
- , b ")" T_cparen
- , b "*" T_star
- , b "**" T_starstar
- , b "+" T_plus
- , b "++" T_plusplus
- , b "," T_comma
- , b "-" T_minus
- , b "->" T_rarrow
- , b "." T_dot
- , b "/" T_alt
- , b ":" T_colon
- , b ";" T_semicolon
- , b "<" T_less
- , b "=" T_equal
- , b "=>" T_big_rarrow
- , b ">" T_great
- , b "?" T_questmark
- , b "[" T_obrack
- , b "]" T_cbrack
- , b "\\" T_lam
- , b "\\\\" T_lamlam
- , b "{" T_ocurly
- , b "}" T_ccurly
- , b "|" T_bar
- , b "_" T_underscore
- , b "@" T_at
- , b "PType" T_PType
- , b "Str" T_Str
- , b "Strs" T_Strs
- , b "Tok" T_Tok
- , b "Type" T_Type
- , b "abstract" T_abstract
- , b "case" T_case
- , b "cat" T_cat
- , b "concrete" T_concrete
- , b "data" T_data
- , b "def" T_def
- , b "flags" T_flags
- , b "fn" T_fn
- , b "fun" T_fun
- , b "in" T_in
- , b "incomplete" T_incomplete
- , b "instance" T_instance
- , b "interface" T_interface
- , b "let" T_let
- , b "lin" T_lin
- , b "lincat" T_lincat
- , b "lindef" T_lindef
- , b "of" T_of
- , b "open" T_open
- , b "oper" T_oper
- , b "param" T_param
- , b "pattern" T_pattern
- , b "pre" T_pre
- , b "printname" T_printname
- , b "resource" T_resource
- , b "strs" T_strs
- , b "table" T_table
- , b "transfer" T_transfer
- , b "variants" T_variants
- , b "where" T_where
- , b "with" T_with
- ]
- where b s t = (BS.pack s, t)
-
-unescapeInitTail :: String -> String
-unescapeInitTail = unesc . tail where
- unesc s = case s of
- '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
- '\\':'n':cs -> '\n' : unesc cs
- '\\':'t':cs -> '\t' : unesc cs
- '"':[] -> []
- c:cs -> c : unesc cs
- _ -> []
-
--------------------------------------------------------------------
--- Alex wrapper code.
--- A modified "posn" wrapper.
--------------------------------------------------------------------
-
-data Posn = Pn {-# UNPACK #-} !Int
- {-# UNPACK #-} !Int
-
-alexMove :: Posn -> Char -> Posn
-alexMove (Pn l c) '\n' = Pn (l+1) 1
-alexMove (Pn l c) _ = Pn l (c+1)
-
-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
-alexGetChar (AI p _ s) =
- case BS.uncons s of
- Nothing -> Nothing
- Just (c,s) ->
- let p' = alexMove p c
- in p' `seq` Just (c, (AI p' c s))
-
-alexInputPrevChar :: AlexInput -> Char
-alexInputPrevChar (AI p c s) = c
-
-data AlexInput = AI {-# UNPACK #-} !Posn -- current position,
- {-# UNPACK #-} !Char -- previous char
- {-# UNPACK #-} !BS.ByteString -- current input string
-
-data ParseResult a
- = POk AlexInput a
- | PFailed Posn -- The position of the error
- String -- The error message
-
-newtype P a = P { unP :: AlexInput -> ParseResult a }
-
-instance Monad P where
- return a = a `seq` (P $ \s -> POk s a)
- (P m) >>= k = P $ \ s -> case m s of
- POk s1 a -> unP (k a) s1
- PFailed posn err -> PFailed posn err
- fail msg = P $ \(AI posn _ _) -> PFailed posn msg
-
-runP :: P a -> BS.ByteString -> Either (Posn,String) a
-runP (P f) txt =
- case f (AI (Pn 1 0) ' ' txt) of
- POk _ x -> Right x
- PFailed pos msg -> Left (pos,msg)
-
-failLoc :: Posn -> String -> P a
-failLoc pos msg = P $ \_ -> PFailed pos msg
-
-lexer :: (Token -> P a) -> P a
-lexer cont = P go
- where
- go inp@(AI pos _ str) =
- case alexScan inp 0 of
- AlexEOF -> unP (cont T_EOF) inp
- AlexError (AI pos _ _) -> PFailed pos "lexical error"
- AlexSkip inp' len -> go inp'
- AlexToken inp' len act -> unP (cont (act pos (BS.take len str))) inp'
-
-getPosn :: P Posn
-getPosn = P $ \inp@(AI pos _ _) -> POk inp pos
-
-
-alex_action_3 = tok (eitherResIdent (T_Ident . identC))
-alex_action_4 = tok (eitherResIdent (T_LString . BS.unpack))
-alex_action_5 = tok (eitherResIdent (T_Ident . identC))
-alex_action_6 = tok (T_String . unescapeInitTail . BS.unpack)
-alex_action_7 = tok (T_Integer . read . BS.unpack)
-alex_action_8 = tok (T_Double . read . BS.unpack)
-{-# LINE 1 "templates/GenericTemplate.hs" #-}
-{-# LINE 1 "templates/GenericTemplate.hs" #-}
-{-# LINE 1 "<built-in>" #-}
-{-# LINE 1 "<command line>" #-}
-{-# LINE 1 "templates/GenericTemplate.hs" #-}
--- -----------------------------------------------------------------------------
--- ALEX TEMPLATE
---
--- This code is in the PUBLIC DOMAIN; you may copy it freely and use
--- it for any purpose whatsoever.
-
--- -----------------------------------------------------------------------------
--- INTERNALS and main scanner engine
-
-{-# LINE 35 "templates/GenericTemplate.hs" #-}
-
-{-# LINE 45 "templates/GenericTemplate.hs" #-}
-
-
-data AlexAddr = AlexA# Addr#
-
-#if __GLASGOW_HASKELL__ < 503
-uncheckedShiftL# = shiftL#
-#endif
-
-{-# INLINE alexIndexInt16OffAddr #-}
-alexIndexInt16OffAddr (AlexA# arr) off =
-#ifdef WORDS_BIGENDIAN
- narrow16Int# i
- where
- i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
- high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
- low = int2Word# (ord# (indexCharOffAddr# arr off'))
- off' = off *# 2#
-#else
- indexInt16OffAddr# arr off
-#endif
-
-
-
-
-
-{-# INLINE alexIndexInt32OffAddr #-}
-alexIndexInt32OffAddr (AlexA# arr) off =
-#ifdef WORDS_BIGENDIAN
- narrow32Int# i
- where
- i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`
- (b2 `uncheckedShiftL#` 16#) `or#`
- (b1 `uncheckedShiftL#` 8#) `or#` b0)
- b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))
- b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))
- b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
- b0 = int2Word# (ord# (indexCharOffAddr# arr off'))
- off' = off *# 4#
-#else
- indexInt32OffAddr# arr off
-#endif
-
-
-
-
-
-#if __GLASGOW_HASKELL__ < 503
-quickIndex arr i = arr ! i
-#else
--- GHC >= 503, unsafeAt is available from Data.Array.Base.
-quickIndex = unsafeAt
-#endif
-
-
-
-
--- -----------------------------------------------------------------------------
--- Main lexing routines
-
-data AlexReturn a
- = AlexEOF
- | AlexError !AlexInput
- | AlexSkip !AlexInput !Int
- | AlexToken !AlexInput !Int a
-
--- alexScan :: AlexInput -> StartCode -> AlexReturn a
-alexScan input (I# (sc))
- = alexScanUser undefined input (I# (sc))
-
-alexScanUser user input (I# (sc))
- = case alex_scan_tkn user input 0# input sc AlexNone of
- (AlexNone, input') ->
- case alexGetChar input of
- Nothing ->
-
-
-
- AlexEOF
- Just _ ->
-
-
-
- AlexError input'
-
- (AlexLastSkip input len, _) ->
-
-
-
- AlexSkip input len
-
- (AlexLastAcc k input len, _) ->
-
-
-
- AlexToken input len k
-
-
--- Push the input through the DFA, remembering the most recent accepting
--- state it encountered.
-
-alex_scan_tkn user orig_input len input s last_acc =
- input `seq` -- strict in the input
- let
- new_acc = check_accs (alex_accept `quickIndex` (I# (s)))
- in
- new_acc `seq`
- case alexGetChar input of
- Nothing -> (new_acc, input)
- Just (c, new_input) ->
-
-
-
- let
- base = alexIndexInt32OffAddr alex_base s
- (I# (ord_c)) = ord c
- offset = (base +# ord_c)
- check = alexIndexInt16OffAddr alex_check offset
-
- new_s = if (offset >=# 0#) && (check ==# ord_c)
- then alexIndexInt16OffAddr alex_table offset
- else alexIndexInt16OffAddr alex_deflt s
- in
- case new_s of
- -1# -> (new_acc, input)
- -- on an error, we want to keep the input *before* the
- -- character that failed, not after.
- _ -> alex_scan_tkn user orig_input (len +# 1#)
- new_input new_s new_acc
-
- where
- check_accs [] = last_acc
- check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))
- check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))
- check_accs (AlexAccPred a pred : rest)
- | pred user orig_input (I# (len)) input
- = AlexLastAcc a input (I# (len))
- check_accs (AlexAccSkipPred pred : rest)
- | pred user orig_input (I# (len)) input
- = AlexLastSkip input (I# (len))
- check_accs (_ : rest) = check_accs rest
-
-data AlexLastAcc a
- = AlexNone
- | AlexLastAcc a !AlexInput !Int
- | AlexLastSkip !AlexInput !Int
-
-data AlexAcc a user
- = AlexAcc a
- | AlexAccSkip
- | AlexAccPred a (AlexAccPred user)
- | AlexAccSkipPred (AlexAccPred user)
-
-type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool
-
--- -----------------------------------------------------------------------------
--- Predicates on a rule
-
-alexAndPred p1 p2 user in1 len in2
- = p1 user in1 len in2 && p2 user in1 len in2
-
---alexPrevCharIsPred :: Char -> AlexAccPred _
-alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input
-
---alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _
-alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input
-
---alexRightContext :: Int -> AlexAccPred _
-alexRightContext (I# (sc)) user _ _ input =
- case alex_scan_tkn user input 0# input sc AlexNone of
- (AlexNone, _) -> False
- _ -> True
- -- TODO: there's no need to find the longest
- -- match when checking the right context, just
- -- the first match will do.
-
--- used by wrappers
-iUnbox (I# (i)) = i
diff --git a/src/GF/Grammar/Lexer.x b/src/GF/Grammar/Lexer.x
deleted file mode 100644
index d6f49bbb1..000000000
--- a/src/GF/Grammar/Lexer.x
+++ /dev/null
@@ -1,272 +0,0 @@
--- -*- haskell -*-
--- This Alex file was machine-generated by the BNF converter
-{
-module GF.Grammar.Lexer
- ( Token(..), Posn(..)
- , P, runP, lexer, getPosn, failLoc
- , isReservedWord
- ) where
-
-import GF.Infra.Ident
-import GF.Data.Operations
-import qualified Data.ByteString.Char8 as BS
-import qualified Data.Map as Map
-
-}
-
-
-$l = [a-zA-Z\192 - \255] # [\215 \247] -- isolatin1 letter FIXME
-$c = [A-Z\192-\221] # [\215] -- capital isolatin1 letter FIXME
-$s = [a-z\222-\255] # [\247] -- small isolatin1 letter FIXME
-$d = [0-9] -- digit
-$i = [$l $d _ '] -- identifier character
-$u = [\0-\255] -- universal: any character
-
-@rsyms = -- symbols and non-identifier-like reserved words
- \; | \= | \{ | \} | \( | \) | \* \* | \: | \- \> | \, | \[ | \] | \- | \. | \| | \% | \? | \< | \> | \@ | \# | \! | \* | \+ | \+ \+ | \\ | \\\\ | \= \> | \_ | \$ | \/
-
-:-
-"--" [.]* ; -- Toss single line comments
-"{-" ([$u # \-] | \- [$u # \}])* ("-")+ "}" ;
-
-$white+ ;
-@rsyms { tok (eitherResIdent (T_Ident . identC)) }
-\' ($u # \')* \' { tok (eitherResIdent (T_LString . BS.unpack)) }
-(\_ | $l)($l | $d | \_ | \')* { tok (eitherResIdent (T_Ident . identC)) }
-
-\" ([$u # [\" \\ \n]] | (\\ (\" | \\ | \' | n | t)))* \" { tok (T_String . unescapeInitTail . BS.unpack) }
-
-$d+ { tok (T_Integer . read . BS.unpack) }
-$d+ \. $d+ (e (\-)? $d+)? { tok (T_Double . read . BS.unpack) }
-
-{
-
-tok f p s = f s
-
-data Token
- = T_exclmark
- | T_patt
- | T_int_label
- | T_oparen
- | T_cparen
- | T_star
- | T_starstar
- | T_plus
- | T_plusplus
- | T_comma
- | T_minus
- | T_rarrow
- | T_dot
- | T_alt
- | T_colon
- | T_semicolon
- | T_less
- | T_equal
- | T_big_rarrow
- | T_great
- | T_questmark
- | T_obrack
- | T_lam
- | T_lamlam
- | T_cbrack
- | T_ocurly
- | T_bar
- | T_ccurly
- | T_underscore
- | T_at
- | T_PType
- | T_Str
- | T_Strs
- | T_Tok
- | T_Type
- | T_abstract
- | T_case
- | T_cat
- | T_concrete
- | T_data
- | T_def
- | T_flags
- | T_fn
- | T_fun
- | T_in
- | T_incomplete
- | T_instance
- | T_interface
- | T_let
- | T_lin
- | T_lincat
- | T_lindef
- | T_of
- | T_open
- | T_oper
- | T_param
- | T_pattern
- | T_pre
- | T_printname
- | T_resource
- | T_strs
- | T_table
- | T_transfer
- | T_variants
- | T_where
- | T_with
- | T_String String -- string literals
- | T_Integer Integer -- integer literals
- | T_Double Double -- double precision float literals
- | T_LString String
- | T_Ident Ident
- | T_EOF
-
-eitherResIdent :: (BS.ByteString -> Token) -> BS.ByteString -> Token
-eitherResIdent tv s =
- case Map.lookup s resWords of
- Just t -> t
- Nothing -> tv s
-
-isReservedWord :: BS.ByteString -> Bool
-isReservedWord s = Map.member s resWords
-
-resWords = Map.fromList
- [ b "!" T_exclmark
- , b "#" T_patt
- , b "$" T_int_label
- , b "(" T_oparen
- , b ")" T_cparen
- , b "*" T_star
- , b "**" T_starstar
- , b "+" T_plus
- , b "++" T_plusplus
- , b "," T_comma
- , b "-" T_minus
- , b "->" T_rarrow
- , b "." T_dot
- , b "/" T_alt
- , b ":" T_colon
- , b ";" T_semicolon
- , b "<" T_less
- , b "=" T_equal
- , b "=>" T_big_rarrow
- , b ">" T_great
- , b "?" T_questmark
- , b "[" T_obrack
- , b "]" T_cbrack
- , b "\\" T_lam
- , b "\\\\" T_lamlam
- , b "{" T_ocurly
- , b "}" T_ccurly
- , b "|" T_bar
- , b "_" T_underscore
- , b "@" T_at
- , b "PType" T_PType
- , b "Str" T_Str
- , b "Strs" T_Strs
- , b "Tok" T_Tok
- , b "Type" T_Type
- , b "abstract" T_abstract
- , b "case" T_case
- , b "cat" T_cat
- , b "concrete" T_concrete
- , b "data" T_data
- , b "def" T_def
- , b "flags" T_flags
- , b "fn" T_fn
- , b "fun" T_fun
- , b "in" T_in
- , b "incomplete" T_incomplete
- , b "instance" T_instance
- , b "interface" T_interface
- , b "let" T_let
- , b "lin" T_lin
- , b "lincat" T_lincat
- , b "lindef" T_lindef
- , b "of" T_of
- , b "open" T_open
- , b "oper" T_oper
- , b "param" T_param
- , b "pattern" T_pattern
- , b "pre" T_pre
- , b "printname" T_printname
- , b "resource" T_resource
- , b "strs" T_strs
- , b "table" T_table
- , b "transfer" T_transfer
- , b "variants" T_variants
- , b "where" T_where
- , b "with" T_with
- ]
- where b s t = (BS.pack s, t)
-
-unescapeInitTail :: String -> String
-unescapeInitTail = unesc . tail where
- unesc s = case s of
- '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs
- '\\':'n':cs -> '\n' : unesc cs
- '\\':'t':cs -> '\t' : unesc cs
- '"':[] -> []
- c:cs -> c : unesc cs
- _ -> []
-
--------------------------------------------------------------------
--- Alex wrapper code.
--- A modified "posn" wrapper.
--------------------------------------------------------------------
-
-data Posn = Pn {-# UNPACK #-} !Int
- {-# UNPACK #-} !Int
-
-alexMove :: Posn -> Char -> Posn
-alexMove (Pn l c) '\n' = Pn (l+1) 1
-alexMove (Pn l c) _ = Pn l (c+1)
-
-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
-alexGetChar (AI p _ s) =
- case BS.uncons s of
- Nothing -> Nothing
- Just (c,s) ->
- let p' = alexMove p c
- in p' `seq` Just (c, (AI p' c s))
-
-alexInputPrevChar :: AlexInput -> Char
-alexInputPrevChar (AI p c s) = c
-
-data AlexInput = AI {-# UNPACK #-} !Posn -- current position,
- {-# UNPACK #-} !Char -- previous char
- {-# UNPACK #-} !BS.ByteString -- current input string
-
-data ParseResult a
- = POk a
- | PFailed Posn -- The position of the error
- String -- The error message
-
-newtype P a = P { unP :: AlexInput -> ParseResult a }
-
-instance Monad P where
- return a = a `seq` (P $ \s -> POk a)
- (P m) >>= k = P $ \ s -> case m s of
- POk a -> unP (k a) s
- PFailed posn err -> PFailed posn err
- fail msg = P $ \(AI posn _ _) -> PFailed posn msg
-
-runP :: P a -> BS.ByteString -> Either (Posn,String) a
-runP (P f) txt =
- case f (AI (Pn 1 0) ' ' txt) of
- POk x -> Right x
- PFailed pos msg -> Left (pos,msg)
-
-failLoc :: Posn -> String -> P a
-failLoc pos msg = P $ \_ -> PFailed pos msg
-
-lexer :: (Token -> P a) -> P a
-lexer cont = P go
- where
- go inp@(AI pos _ str) =
- case alexScan inp 0 of
- AlexEOF -> unP (cont T_EOF) inp
- AlexError (AI pos _ _) -> PFailed pos "lexical error"
- AlexSkip inp' len -> go inp'
- AlexToken inp' len act -> unP (cont (act pos (BS.take len str))) inp'
-
-getPosn :: P Posn
-getPosn = P $ \inp@(AI pos _ _) -> POk pos
-
-}
diff --git a/src/GF/Grammar/Lockfield.hs b/src/GF/Grammar/Lockfield.hs
deleted file mode 100644
index 3e78a48b6..000000000
--- a/src/GF/Grammar/Lockfield.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Lockfield
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/11 23:24:34 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.7 $
---
--- Creating and using lock fields in reused resource grammars.
---
--- AR 8\/2\/2005 detached from 'compile/MkResource'
------------------------------------------------------------------------------
-
-module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where
-
-import qualified Data.ByteString.Char8 as BS
-
-import GF.Infra.Ident
-import GF.Grammar.Grammar
-import GF.Grammar.Macros
-
-import GF.Data.Operations
-
-lockRecType :: Ident -> Type -> Err Type
-lockRecType c t@(RecType rs) =
- let lab = lockLabel c in
- return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"]
- then t --- don't add an extra copy of lock field, nor predef cats
- else RecType (rs ++ [(lockLabel c, RecType [])])
-lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])]
-
-unlockRecord :: Ident -> Term -> Err Term
-unlockRecord c ft = do
- let (xs,t) = termFormCnc ft
- let lock = R [(lockLabel c, (Just (RecType []),R []))]
- case plusRecord t lock of
- Ok t' -> return $ mkAbs xs t'
- _ -> return $ mkAbs xs (ExtR t lock)
-
-lockLabel :: Ident -> Label
-lockLabel c = LIdent $! BS.append lockPrefix (ident2bs c)
-
-isLockLabel :: Label -> Bool
-isLockLabel l = case l of
- LIdent c -> BS.isPrefixOf lockPrefix c
- _ -> False
-
-
-lockPrefix = BS.pack "lock_"
diff --git a/src/GF/Grammar/Lookup.hs b/src/GF/Grammar/Lookup.hs
deleted file mode 100644
index 074f0c5ec..000000000
--- a/src/GF/Grammar/Lookup.hs
+++ /dev/null
@@ -1,188 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------
--- |
--- Module : Lookup
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/27 13:21:53 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.15 $
---
--- Lookup in source (concrete and resource) when compiling.
---
--- lookup in resource and concrete in compiling; for abstract, use 'Look'
------------------------------------------------------------------------------
-
-module GF.Grammar.Lookup (
- lookupIdent,
- lookupIdentInfo,
- lookupOrigInfo,
- allOrigInfos,
- lookupResDef,
- lookupResType,
- lookupOverload,
- lookupParamValues,
- allParamValues,
- lookupAbsDef,
- lookupLincat,
- lookupFunType,
- lookupCatContext
- ) where
-
-import GF.Data.Operations
-import GF.Infra.Ident
-import GF.Infra.Modules
-import GF.Grammar.Macros
-import GF.Grammar.Grammar
-import GF.Grammar.Printer
-import GF.Grammar.Predef
-import GF.Grammar.Lockfield
-
-import Data.List (nub,sortBy)
-import Control.Monad
-import Text.PrettyPrint
-
--- whether lock fields are added in reuse
-lock c = lockRecType c -- return
-unlock c = unlockRecord c -- return
-
--- to look up a constant etc in a search tree --- why here? AR 29/5/2008
-lookupIdent :: Ident -> BinTree Ident b -> Err b
-lookupIdent c t =
- case lookupTree showIdent c t of
- Ok v -> return v
- Bad _ -> Bad ("unknown identifier" +++ showIdent c)
-
-lookupIdentInfo :: ModInfo Ident a -> Ident -> Err a
-lookupIdentInfo mo i = lookupIdent i (jments mo)
-
-lookupResDef :: SourceGrammar -> Ident -> Ident -> Err Term
-lookupResDef gr m c
- | isPredefCat c = lock c defLinType
- | otherwise = look m c
- where
- look m c = do
- mo <- lookupModule gr m
- info <- lookupIdentInfo mo c
- case info of
- ResOper _ (Just t) -> return t
- ResOper _ Nothing -> return (Q m c)
- CncCat (Just ty) _ _ -> lock c ty
- CncCat _ _ _ -> lock c defLinType
-
- CncFun (Just (cat,_,_)) (Just tr) _ -> unlock cat tr
- CncFun _ (Just tr) _ -> return tr
-
- AnyInd _ n -> look n c
- ResParam _ _ -> return (QC m c)
- ResValue _ -> return (QC m c)
- _ -> Bad $ render (ppIdent c <+> text "is not defined in resource" <+> ppIdent m)
-
-lookupResType :: SourceGrammar -> Ident -> Ident -> Err Type
-lookupResType gr m c = do
- mo <- lookupModule gr m
- info <- lookupIdentInfo mo c
- case info of
- ResOper (Just t) _ -> return t
-
- -- used in reused concrete
- CncCat _ _ _ -> return typeType
- CncFun (Just (cat,cont,val)) _ _ -> do
- val' <- lock cat val
- return $ mkProd cont val' []
- AnyInd _ n -> lookupResType gr n c
- ResParam _ _ -> return typePType
- ResValue t -> return t
- _ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
-
-lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))]
-lookupOverload gr m c = do
- mo <- lookupModule gr m
- info <- lookupIdentInfo mo c
- 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)) |
- (ty,tr) <- tysts] ++
- concat tss
-
- AnyInd _ n -> lookupOverload gr n c
- _ -> Bad $ render (ppIdent c <+> text "is not an overloaded operation")
-
--- | returns the original 'Info' and the module where it was found
-lookupOrigInfo :: SourceGrammar -> Ident -> Ident -> Err (Ident,Info)
-lookupOrigInfo gr m c = do
- mo <- lookupModule gr m
- info <- lookupIdentInfo mo c
- case info of
- AnyInd _ n -> lookupOrigInfo gr n c
- i -> return (m,i)
-
-allOrigInfos :: SourceGrammar -> Ident -> [(Ident,Info)]
-allOrigInfos gr m = errVal [] $ do
- mo <- lookupModule gr m
- return [(c,i) | (c,_) <- tree2list (jments mo), Ok (_,i) <- [look c]]
- where
- look = lookupOrigInfo gr m
-
-lookupParamValues :: SourceGrammar -> Ident -> Ident -> Err [Term]
-lookupParamValues gr m c = do
- (_,info) <- lookupOrigInfo gr m c
- case info of
- ResParam _ (Just pvs) -> return pvs
- _ -> Bad $ render (ppIdent c <+> text "has no parameter values defined in resource" <+> ppIdent m)
-
-allParamValues :: SourceGrammar -> Type -> Err [Term]
-allParamValues cnc ptyp = case ptyp of
- _ | Just n <- isTypeInts ptyp -> return [EInt i | i <- [0..n]]
- QC p c -> lookupParamValues cnc p c
- Q p c -> lookupResDef cnc p c >>= allParamValues cnc
- RecType r -> do
- let (ls,tys) = unzip $ sortByFst r
- tss <- mapM (allParamValues cnc) tys
- return [R (zipAssign ls ts) | ts <- combinations tss]
- _ -> Bad (render (text "cannot find parameter values for" <+> ppTerm Unqualified 0 ptyp))
- where
- -- to normalize records and record types
- sortByFst = sortBy (\ x y -> compare (fst x) (fst y))
-
-lookupAbsDef :: SourceGrammar -> Ident -> Ident -> Err (Maybe Int,Maybe [Equation])
-lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c)) $ do
- mo <- lookupModule gr m
- info <- lookupIdentInfo mo c
- case info of
- AbsFun _ a d -> return (a,d)
- AnyInd _ n -> lookupAbsDef gr n c
- _ -> return (Nothing,Nothing)
-
-lookupLincat :: SourceGrammar -> Ident -> Ident -> Err Type
-lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
-lookupLincat gr m c = do
- mo <- lookupModule gr m
- info <- lookupIdentInfo mo c
- case info of
- CncCat (Just t) _ _ -> return t
- AnyInd _ n -> lookupLincat gr n c
- _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
-
--- | this is needed at compile time
-lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
-lookupFunType gr m c = do
- mo <- lookupModule gr m
- info <- lookupIdentInfo mo c
- case info of
- AbsFun (Just t) _ _ -> return t
- AnyInd _ n -> lookupFunType gr n c
- _ -> Bad (render (text "cannot find type of" <+> ppIdent c))
-
--- | this is needed at compile time
-lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
-lookupCatContext gr m c = do
- mo <- lookupModule gr m
- info <- lookupIdentInfo mo c
- case info of
- AbsCat (Just co) _ -> return co
- AnyInd _ n -> lookupCatContext gr n c
- _ -> Bad (render (text "unknown category" <+> ppIdent c))
diff --git a/src/GF/Grammar/MMacros.hs b/src/GF/Grammar/MMacros.hs
deleted file mode 100644
index a7f746b66..000000000
--- a/src/GF/Grammar/MMacros.hs
+++ /dev/null
@@ -1,279 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : MMacros
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/05/10 12:49:13 $
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.9 $
---
--- some more abstractions on grammars, esp. for Edit
------------------------------------------------------------------------------
-
-module GF.Grammar.MMacros where
-
-import GF.Data.Operations
---import GF.Data.Zipper
-
-import GF.Grammar.Grammar
-import GF.Grammar.Printer
-import GF.Infra.Ident
-import GF.Compile.Refresh
-import GF.Grammar.Values
-----import GrammarST
-import GF.Grammar.Macros
-
-import Control.Monad
-import qualified Data.ByteString.Char8 as BS
-import Text.PrettyPrint
-
-{-
-nodeTree :: Tree -> TrNode
-argsTree :: Tree -> [Tree]
-
-nodeTree (Tr (n,_)) = n
-argsTree (Tr (_,ts)) = ts
-
-isFocusNode :: TrNode -> Bool
-bindsNode :: TrNode -> Binds
-atomNode :: TrNode -> Atom
-valNode :: TrNode -> Val
-constrsNode :: TrNode -> Constraints
-metaSubstsNode :: TrNode -> MetaSubst
-
-isFocusNode (N (_,_,_,_,b)) = b
-bindsNode (N (b,_,_,_,_)) = b
-atomNode (N (_,a,_,_,_)) = a
-valNode (N (_,_,v,_,_)) = v
-constrsNode (N (_,_,_,(c,_),_)) = c
-metaSubstsNode (N (_,_,_,(_,m),_)) = m
-
-atomTree :: Tree -> Atom
-valTree :: Tree -> Val
-
-atomTree = atomNode . nodeTree
-valTree = valNode . nodeTree
-
-mkNode :: Binds -> Atom -> Val -> (Constraints, MetaSubst) -> TrNode
-mkNode binds atom vtyp cs = N (binds,atom,vtyp,cs,False)
-
-metasTree :: Tree -> [MetaId]
-metasTree = concatMap metasNode . scanTree where
- metasNode n = [m | AtM m <- [atomNode n]] ++ map fst (metaSubstsNode n)
-
-varsTree :: Tree -> [(Var,Val)]
-varsTree t = [(x,v) | N (_,AtV x,v,_,_) <- scanTree t]
-
-constrsTree :: Tree -> Constraints
-constrsTree = constrsNode . nodeTree
-
-allConstrsTree :: Tree -> Constraints
-allConstrsTree = concatMap constrsNode . scanTree
-
-changeConstrs :: (Constraints -> Constraints) -> TrNode -> TrNode
-changeConstrs f (N (b,a,v,(c,m),x)) = N (b,a,v,(f c, m),x)
-
-changeMetaSubst :: (MetaSubst -> MetaSubst) -> TrNode -> TrNode
-changeMetaSubst f (N (b,a,v,(c,m),x)) = N (b,a,v,(c, f m),x)
-
-changeAtom :: (Atom -> Atom) -> TrNode -> TrNode
-changeAtom f (N (b,a,v,(c,m),x)) = N (b,f a,v,(c, m),x)
-
--- * on the way to Edit
-
-uTree :: Tree
-uTree = Tr (uNode, []) -- unknown tree
-
-uNode :: TrNode
-uNode = mkNode [] uAtom uVal ([],[])
-
-
-uAtom :: Atom
-uAtom = AtM meta0
-
-mAtom :: Atom
-mAtom = AtM meta0
--}
-
-type Var = Ident
-
-uVal :: Val
-uVal = vClos uExp
-
-vClos :: Exp -> Val
-vClos = VClos []
-
-uExp :: Exp
-uExp = Meta meta0
-
-mExp, mExp0 :: Exp
-mExp = Meta meta0
-mExp0 = mExp
-
-meta2exp :: MetaId -> Exp
-meta2exp = Meta
-{-
-atomC :: Fun -> Atom
-atomC = AtC
-
-funAtom :: Atom -> Err Fun
-funAtom a = case a of
- AtC f -> return f
- _ -> prtBad "not function head" a
-
-atomIsMeta :: Atom -> Bool
-atomIsMeta atom = case atom of
- AtM _ -> True
- _ -> False
-
-getMetaAtom :: Atom -> Err MetaId
-getMetaAtom a = case a of
- AtM m -> return m
- _ -> Bad "the active node is not meta"
--}
-cat2val :: Context -> Cat -> Val
-cat2val cont cat = vClos $ mkApp (uncurry Q cat) [Meta i | i <- [1..length cont]]
-
-val2cat :: Val -> Err Cat
-val2cat v = liftM valCat (val2exp v)
-
-substTerm :: [Ident] -> Substitution -> Term -> Term
-substTerm ss g c = case c of
- Vr x -> maybe c id $ lookup x g
- App f a -> App (substTerm ss g f) (substTerm ss g a)
- Abs b x t -> let y = mkFreshVarX ss x in
- Abs b y (substTerm (y:ss) ((x, Vr y):g) t)
- Prod b x a t -> let y = mkFreshVarX ss x in
- Prod b y (substTerm ss g a) (substTerm (y:ss) ((x,Vr y):g) t)
- _ -> c
-
-metaSubstExp :: MetaSubst -> [(MetaId,Exp)]
-metaSubstExp msubst = [(m, errVal (meta2exp m) (val2expSafe v)) | (m,v) <- msubst]
-
--- * belong here rather than to computation
-
-substitute :: [Var] -> Substitution -> Exp -> Err Exp
-substitute v s = return . substTerm v s
-
-alphaConv :: [Var] -> (Var,Var) -> Exp -> Err Exp ---
-alphaConv oldvars (x,x') = substitute (x:x':oldvars) [(x,Vr x')]
-
-alphaFresh :: [Var] -> Exp -> Err Exp
-alphaFresh vs = refreshTermN $ maxVarIndex vs
-
--- | done in a state monad
-alphaFreshAll :: [Var] -> [Exp] -> Err [Exp]
-alphaFreshAll vs = mapM $ alphaFresh vs
-
--- | for display
-val2exp :: Val -> Err Exp
-val2exp = val2expP False
-
--- | for type checking
-val2expSafe :: Val -> Err Exp
-val2expSafe = val2expP True
-
-val2expP :: Bool -> Val -> Err Exp
-val2expP safe v = case v of
-
- VClos g@(_:_) e@(Meta _) -> if safe
- then Bad (render (text "unsafe value substitution" <+> ppValue Unqualified 0 v))
- else substVal g e
- VClos g e -> substVal g e
- VApp f c -> liftM2 App (val2expP safe f) (val2expP safe c)
- VCn c -> return $ uncurry Q c
- VGen i x -> if safe
- then Bad (render (text "unsafe val2exp" <+> ppValue Unqualified 0 v))
- else return $ Vr $ x --- in editing, no alpha conversions presentv
- VRecType xs->do xs <- mapM (\(l,v) -> val2expP safe v >>= \e -> return (l,e)) xs
- return (RecType xs)
- VType -> return typeType
- where
- substVal g e = mapPairsM (val2expP safe) g >>= return . (\s -> substTerm [] s e)
-
-isConstVal :: Val -> Bool
-isConstVal v = case v of
- VApp f c -> isConstVal f && isConstVal c
- VCn _ -> True
- VClos [] e -> null $ freeVarsExp e
- _ -> False --- could be more liberal
-
-mkProdVal :: Binds -> Val -> Err Val ---
-mkProdVal bs v = do
- bs' <- mapPairsM val2exp bs
- v' <- val2exp v
- return $ vClos $ foldr (uncurry (Prod Explicit)) v' bs'
-
-freeVarsExp :: Exp -> [Ident]
-freeVarsExp e = case e of
- Vr x -> [x]
- App f c -> freeVarsExp f ++ freeVarsExp c
- Abs _ x b -> filter (/=x) (freeVarsExp b)
- Prod _ x a b -> freeVarsExp a ++ filter (/=x) (freeVarsExp b)
- _ -> [] --- thus applies to abstract syntax only
-
-int2var :: Int -> Ident
-int2var = identC . BS.pack . ('$':) . show
-
-meta0 :: MetaId
-meta0 = 0
-
-termMeta0 :: Term
-termMeta0 = Meta meta0
-
-identVar :: Term -> Err Ident
-identVar (Vr x) = return x
-identVar _ = Bad "not a variable"
-
-
--- | light-weight rename for user interaction; also change names of internal vars
-qualifTerm :: Ident -> Term -> Term
-qualifTerm m = qualif [] where
- qualif xs t = case t of
- Abs b x t -> let x' = chV x in Abs b x' $ qualif (x':xs) t
- Prod b x a t -> Prod b x (qualif xs a) $ qualif (x:xs) t
- Vr x -> let x' = chV x in if (elem x' xs) then (Vr x') else (Q m x)
- Cn c -> Q m c
- Con c -> QC m c
- _ -> composSafeOp (qualif xs) t
- chV x = string2var $ ident2bs x
-
-string2var :: BS.ByteString -> Ident
-string2var s = case BS.unpack s of
- c:'_':i -> identV (BS.singleton c) (readIntArg i) ---
- _ -> identC s
-
--- | reindex variables so that they tell nesting depth level
-reindexTerm :: Term -> Term
-reindexTerm = qualif (0,[]) where
- qualif dg@(d,g) t = case t of
- Abs b x t -> let x' = ind x d in Abs b x' $ qualif (d+1, (x,x'):g) t
- Prod b x a t -> let x' = ind x d in Prod b x' (qualif dg a) $ qualif (d+1, (x,x'):g) t
- Vr x -> Vr $ look x g
- _ -> composSafeOp (qualif dg) t
- look x = maybe x id . lookup x --- if x is not in scope it is unchanged
- ind x d = identC $ ident2bs x `BS.append` BS.singleton '_' `BS.append` BS.pack (show d)
-
-{-
--- this method works for context-free abstract syntax
--- and is meant to be used in simple embedded GF applications
-
-exp2tree :: Exp -> Err Tree
-exp2tree e = do
- (bs,f,xs) <- termForm e
- cont <- case bs of
- [] -> return []
- _ -> prtBad "cannot convert bindings in" e
- at <- case f of
- Q m c -> return $ AtC (m,c)
- QC m c -> return $ AtC (m,c)
- Meta m -> return $ AtM m
- K s -> return $ AtL s
- EInt n -> return $ AtI n
- EFloat n -> return $ AtF n
- _ -> prtBad "cannot convert to atom" f
- ts <- mapM exp2tree xs
- return $ Tr (N (cont,at,uVal,([],[]),True),ts)
--}
diff --git a/src/GF/Grammar/Macros.hs b/src/GF/Grammar/Macros.hs
deleted file mode 100644
index 799cd9ec5..000000000
--- a/src/GF/Grammar/Macros.hs
+++ /dev/null
@@ -1,627 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Macros
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/11 16:38:00 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.24 $
---
--- Macros for constructing and analysing source code terms.
---
--- operations on terms and types not involving lookup in or reference to grammars
---
--- AR 7\/12\/1999 - 9\/5\/2000 -- 4\/6\/2001
------------------------------------------------------------------------------
-
-module GF.Grammar.Macros where
-
-import GF.Data.Operations
-import GF.Data.Str
-import GF.Infra.Ident
-import GF.Infra.Modules
-import GF.Grammar.Grammar
-import GF.Grammar.Values
-import GF.Grammar.Predef
-import GF.Grammar.Printer
-
-import Control.Monad (liftM, liftM2)
-import Data.Char (isDigit)
-import Data.List (sortBy,nub)
-import Text.PrettyPrint
-
-typeForm :: Type -> (Context, Cat, [Term])
-typeForm t =
- case t of
- Prod b x a t ->
- let (x', cat, args) = typeForm t
- in ((b,x,a):x', cat, args)
- App c a ->
- let (_, cat, args) = typeForm c
- in ([],cat,args ++ [a])
- Q m c -> ([],(m,c),[])
- QC m c -> ([],(m,c),[])
- Sort c -> ([],(identW, c),[])
- _ -> error (render (text "no normal form of type" <+> ppTerm Unqualified 0 t))
-
-typeFormCnc :: Type -> (Context, Type)
-typeFormCnc t =
- case t of
- Prod b x a t -> let (x', v) = typeFormCnc t
- in ((b,x,a):x',v)
- _ -> ([],t)
-
-valCat :: Type -> Cat
-valCat typ =
- let (_,cat,_) = typeForm typ
- in cat
-
-valType :: Type -> Type
-valType typ =
- let (_,cat,xx) = typeForm typ --- not optimal to do in this way
- in mkApp (uncurry Q cat) xx
-
-valTypeCnc :: Type -> Type
-valTypeCnc typ = snd (typeFormCnc typ)
-
-typeSkeleton :: Type -> ([(Int,Cat)],Cat)
-typeSkeleton typ =
- let (cont,cat,_) = typeForm typ
- args = map (\(b,x,t) -> typeSkeleton t) cont
- in ([(length c, v) | (c,v) <- args], cat)
-
-catSkeleton :: Type -> ([Cat],Cat)
-catSkeleton typ =
- let (args,val) = typeSkeleton typ
- in (map snd args, val)
-
-funsToAndFrom :: Type -> (Cat, [(Cat,[Int])])
-funsToAndFrom t =
- let (cs,v) = catSkeleton t
- cis = zip cs [0..]
- in (v, [(c,[i | (c',i) <- cis, c' == c]) | c <- cs])
-
-isRecursiveType :: Type -> Bool
-isRecursiveType t =
- let (cc,c) = catSkeleton t -- thus recursivity on Cat level
- in any (== c) cc
-
-isHigherOrderType :: Type -> Bool
-isHigherOrderType t = errVal True $ do -- pessimistic choice
- co <- contextOfType t
- return $ not $ null [x | (_,x,Prod _ _ _ _) <- co]
-
-contextOfType :: Type -> Err Context
-contextOfType typ = case typ of
- Prod b x a t -> liftM ((b,x,a):) $ contextOfType t
- _ -> return []
-
-termForm :: Term -> Err ([(BindType,Ident)], Term, [Term])
-termForm t = case t of
- Abs b x t ->
- do (x', fun, args) <- termForm t
- return ((b,x):x', fun, args)
- App c a ->
- do (_,fun, args) <- termForm c
- return ([],fun,args ++ [a])
- _ ->
- return ([],t,[])
-
-termFormCnc :: Term -> ([(BindType,Ident)], Term)
-termFormCnc t = case t of
- Abs b x t -> ((b,x):xs, t') where (xs,t') = termFormCnc t
- _ -> ([],t)
-
-appForm :: Term -> (Term, [Term])
-appForm t = case t of
- App c a -> (fun, args ++ [a]) where (fun, args) = appForm c
- _ -> (t,[])
-
-mkProdSimple :: Context -> Term -> Term
-mkProdSimple c t = mkProd c t []
-
-mkProd :: Context -> Term -> [Term] -> Term
-mkProd [] typ args = mkApp typ args
-mkProd ((b,x,a):dd) typ args = Prod b x a (mkProd dd typ args)
-
-mkTerm :: ([(BindType,Ident)], Term, [Term]) -> Term
-mkTerm (xx,t,aa) = mkAbs xx (mkApp t aa)
-
-mkApp :: Term -> [Term] -> Term
-mkApp = foldl App
-
-mkAbs :: [(BindType,Ident)] -> Term -> Term
-mkAbs xx t = foldr (uncurry Abs) t xx
-
-appCons :: Ident -> [Term] -> Term
-appCons = mkApp . Cn
-
-mkLet :: [LocalDef] -> Term -> Term
-mkLet defs t = foldr Let t defs
-
-mkLetUntyped :: Context -> Term -> Term
-mkLetUntyped defs = mkLet [(x,(Nothing,t)) | (_,x,t) <- defs]
-
-isVariable :: Term -> Bool
-isVariable (Vr _ ) = True
-isVariable _ = False
-
-eqIdent :: Ident -> Ident -> Bool
-eqIdent = (==)
-
-uType :: Type
-uType = Cn cUndefinedType
-
-assign :: Label -> Term -> Assign
-assign l t = (l,(Nothing,t))
-
-assignT :: Label -> Type -> Term -> Assign
-assignT l a t = (l,(Just a,t))
-
-unzipR :: [Assign] -> ([Label],[Term])
-unzipR r = (ls, map snd ts) where (ls,ts) = unzip r
-
-mkAssign :: [(Label,Term)] -> [Assign]
-mkAssign lts = [assign l t | (l,t) <- lts]
-
-zipAssign :: [Label] -> [Term] -> [Assign]
-zipAssign ls ts = [assign l t | (l,t) <- zip ls ts]
-
-mapAssignM :: Monad m => (Term -> m c) -> [Assign] -> m [(Label,(Maybe c,c))]
-mapAssignM f = mapM (\ (ls,tv) -> liftM ((,) ls) (g tv))
- where g (t,v) = liftM2 (,) (maybe (return Nothing) (liftM Just . f) t) (f v)
-
-mkRecordN :: Int -> (Int -> Label) -> [Term] -> Term
-mkRecordN int lab typs = R [ assign (lab i) t | (i,t) <- zip [int..] typs]
-
-mkRecord :: (Int -> Label) -> [Term] -> Term
-mkRecord = mkRecordN 0
-
-mkRecTypeN :: Int -> (Int -> Label) -> [Type] -> Type
-mkRecTypeN int lab typs = RecType [ (lab i, t) | (i,t) <- zip [int..] typs]
-
-mkRecType :: (Int -> Label) -> [Type] -> Type
-mkRecType = mkRecTypeN 0
-
-record2subst :: Term -> Err Substitution
-record2subst t = case t of
- R fs -> return [(identC x, t) | (LIdent x,(_,t)) <- fs]
- _ -> Bad (render (text "record expected, found" <+> ppTerm Unqualified 0 t))
-
-typeType, typePType, typeStr, typeTok, typeStrs :: Term
-
-typeType = Sort cType
-typePType = Sort cPType
-typeStr = Sort cStr
-typeTok = Sort cTok
-typeStrs = Sort cStrs
-
-typeString, typeFloat, typeInt :: Term
-typeInts :: Integer -> Term
-typePBool :: Term
-typeError :: Term
-
-typeString = cnPredef cString
-typeInt = cnPredef cInt
-typeFloat = cnPredef cFloat
-typeInts i = App (cnPredef cInts) (EInt i)
-typePBool = cnPredef cPBool
-typeError = cnPredef cErrorType
-
-isTypeInts :: Term -> Maybe Integer
-isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
-isTypeInts _ = Nothing
-
-isPredefConstant :: Term -> Bool
-isPredefConstant t = case t of
- Q mod _ | mod == cPredef || mod == cPredefAbs -> True
- _ -> False
-
-cnPredef :: Ident -> Term
-cnPredef f = Q cPredef f
-
-mkSelects :: Term -> [Term] -> Term
-mkSelects t tt = foldl S t tt
-
-mkTable :: [Term] -> Term -> Term
-mkTable tt t = foldr Table t tt
-
-mkCTable :: [(BindType,Ident)] -> Term -> Term
-mkCTable ids v = foldr ccase v ids where
- ccase (_,x) t = T TRaw [(PV x,t)]
-
-mkHypo :: Term -> Hypo
-mkHypo typ = (Explicit,identW, typ)
-
-eqStrIdent :: Ident -> Ident -> Bool
-eqStrIdent = (==)
-
-tuple2record :: [Term] -> [Assign]
-tuple2record ts = [assign (tupleLabel i) t | (i,t) <- zip [1..] ts]
-
-tuple2recordType :: [Term] -> [Labelling]
-tuple2recordType ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
-
-tuple2recordPatt :: [Patt] -> [(Label,Patt)]
-tuple2recordPatt ts = [(tupleLabel i, t) | (i,t) <- zip [1..] ts]
-
-mkCases :: Ident -> Term -> Term
-mkCases x t = T TRaw [(PV x, t)]
-
-mkWildCases :: Term -> Term
-mkWildCases = mkCases identW
-
-mkFunType :: [Type] -> Type -> Type
-mkFunType tt t = mkProd [(Explicit,identW, ty) | ty <- tt] t [] -- nondep prod
-
-plusRecType :: Type -> Type -> Err Type
-plusRecType t1 t2 = case (t1, t2) of
- (RecType r1, RecType r2) -> case
- filter (`elem` (map fst r1)) (map fst r2) of
- [] -> return (RecType (r1 ++ r2))
- ls -> Bad $ render (text "clashing labels" <+> hsep (map ppLabel ls))
- _ -> Bad $ render (text "cannot add record types" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
-
-plusRecord :: Term -> Term -> Err Term
-plusRecord t1 t2 =
- case (t1,t2) of
- (R r1, R r2 ) -> return (R ([(l,v) | -- overshadowing of old fields
- (l,v) <- r1, not (elem l (map fst r2)) ] ++ r2))
- (_, FV rs) -> mapM (plusRecord t1) rs >>= return . FV
- (FV rs,_ ) -> mapM (`plusRecord` t2) rs >>= return . FV
- _ -> Bad $ render (text "cannot add records" <+> ppTerm Unqualified 0 t1 <+> text "and" <+> ppTerm Unqualified 0 t2)
-
--- | default linearization type
-defLinType :: Type
-defLinType = RecType [(theLinLabel, typeStr)]
-
--- | refreshing variables
-mkFreshVar :: [Ident] -> Ident
-mkFreshVar olds = varX (maxVarIndex olds + 1)
-
--- | trying to preserve a given symbol
-mkFreshVarX :: [Ident] -> Ident -> Ident
-mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x
-
-maxVarIndex :: [Ident] -> Int
-maxVarIndex = maximum . ((-1):) . map varIndex
-
-mkFreshVars :: Int -> [Ident] -> [Ident]
-mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]
-
--- | quick hack for refining with var in editor
-freshAsTerm :: String -> Term
-freshAsTerm s = Vr (varX (readIntArg s))
-
--- | create a terminal for concrete syntax
-string2term :: String -> Term
-string2term = K
-
-int2term :: Integer -> Term
-int2term = EInt
-
-float2term :: Double -> Term
-float2term = EFloat
-
--- | create a terminal from identifier
-ident2terminal :: Ident -> Term
-ident2terminal = K . showIdent
-
-symbolOfIdent :: Ident -> String
-symbolOfIdent = showIdent
-
-symid :: Ident -> String
-symid = symbolOfIdent
-
-justIdentOf :: Term -> Maybe Ident
-justIdentOf (Vr x) = Just x
-justIdentOf (Cn x) = Just x
-justIdentOf _ = Nothing
-
-linTypeStr :: Type
-linTypeStr = mkRecType linLabel [typeStr] -- default lintype {s :: Str}
-
-linAsStr :: String -> Term
-linAsStr s = mkRecord linLabel [K s] -- default linearization {s = s}
-
-term2patt :: Term -> Err Patt
-term2patt trm = case termForm trm of
- Ok ([], Vr x, []) | x == identW -> return PW
- | otherwise -> return (PV x)
- Ok ([], Con c, aa) -> do
- aa' <- mapM term2patt aa
- return (PC c aa')
- Ok ([], QC p c, aa) -> do
- aa' <- mapM term2patt aa
- return (PP p c aa')
-
- Ok ([], Q p c, []) -> do
- return (PM p c)
-
- Ok ([], R r, []) -> do
- let (ll,aa) = unzipR r
- aa' <- mapM term2patt aa
- return (PR (zip ll aa'))
- Ok ([],EInt i,[]) -> return $ PInt i
- Ok ([],EFloat i,[]) -> return $ PFloat i
- Ok ([],K s, []) -> return $ PString s
-
---- encodings due to excessive use of term-patt convs. AR 7/1/2005
- Ok ([], Cn id, [Vr a,b]) | id == cAs -> do
- b' <- term2patt b
- return (PAs a b')
- Ok ([], Cn id, [a]) | id == cNeg -> do
- a' <- term2patt a
- return (PNeg a')
- Ok ([], Cn id, [a]) | id == cRep -> do
- a' <- term2patt a
- return (PRep a')
- Ok ([], Cn id, []) | id == cRep -> do
- return PChar
- Ok ([], Cn id,[K s]) | id == cChars -> do
- return $ PChars s
- Ok ([], Cn id, [a,b]) | id == cSeq -> do
- a' <- term2patt a
- b' <- term2patt b
- return (PSeq a' b')
- Ok ([], Cn id, [a,b]) | id == cAlt -> do
- a' <- term2patt a
- b' <- term2patt b
- return (PAlt a' b')
-
- Ok ([], Cn c, []) -> do
- return (PMacro c)
-
- _ -> Bad $ render (text "no pattern corresponds to term" <+> ppTerm Unqualified 0 trm)
-
-patt2term :: Patt -> Term
-patt2term pt = case pt of
- PV x -> Vr x
- PW -> Vr identW --- not parsable, should not occur
- PMacro c -> Cn c
- PM p c -> Q p c
-
- PC c pp -> mkApp (Con c) (map patt2term pp)
- PP p c pp -> mkApp (QC p c) (map patt2term pp)
-
- PR r -> R [assign l (patt2term p) | (l,p) <- r]
- PT _ p -> patt2term p
- PInt i -> EInt i
- PFloat i -> EFloat i
- PString s -> K s
-
- PAs x p -> appCons cAs [Vr x, patt2term p] --- an encoding
- PChar -> appCons cChar [] --- an encoding
- PChars s -> appCons cChars [K s] --- an encoding
- PSeq a b -> appCons cSeq [(patt2term a), (patt2term b)] --- an encoding
- PAlt a b -> appCons cAlt [(patt2term a), (patt2term b)] --- an encoding
- PRep a -> appCons cRep [(patt2term a)] --- an encoding
- PNeg a -> appCons cNeg [(patt2term a)] --- an encoding
-
-
-redirectTerm :: Ident -> Term -> Term
-redirectTerm n t = case t of
- QC _ f -> QC n f
- Q _ f -> Q n f
- _ -> composSafeOp (redirectTerm n) t
-
--- | to gather ultimate cases in a table; preserves pattern list
-allCaseValues :: Term -> [([Patt],Term)]
-allCaseValues trm = case trm of
- T _ cs -> [(p:ps, t) | (p,t0) <- cs, (ps,t) <- allCaseValues t0]
- _ -> [([],trm)]
-
--- | to get a string from a term that represents a sequence of terminals
-strsFromTerm :: Term -> Err [Str]
-strsFromTerm t = case t of
- K s -> return [str s]
- Empty -> return [str []]
- C s t -> do
- s' <- strsFromTerm s
- t' <- strsFromTerm t
- return [plusStr x y | x <- s', y <- t']
- Glue s t -> do
- s' <- strsFromTerm s
- t' <- strsFromTerm t
- return [glueStr x y | x <- s', y <- t']
- Alts (d,vs) -> do
- d0 <- strsFromTerm d
- v0 <- mapM (strsFromTerm . fst) vs
- c0 <- mapM (strsFromTerm . snd) vs
- let vs' = zip v0 c0
- return [strTok (str2strings def) vars |
- def <- d0,
- vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
- vv <- combinations v0]
- ]
- FV ts -> mapM strsFromTerm ts >>= return . concat
- Strs ts -> mapM strsFromTerm ts >>= return . concat
- _ -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
-
--- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
-stringFromTerm :: Term -> String
-stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm
-
-
--- | to define compositional term functions
-composSafeOp :: (Term -> Term) -> Term -> Term
-composSafeOp op trm = case composOp (mkMonadic op) trm of
- Ok t -> t
- _ -> error "the operation is safe isn't it ?"
- where
- mkMonadic f = return . f
-
--- | to define compositional term functions
-composOp :: Monad m => (Term -> m Term) -> Term -> m Term
-composOp co trm =
- case trm of
- App c a ->
- do c' <- co c
- a' <- co a
- return (App c' a')
- Abs b x t ->
- do t' <- co t
- return (Abs b x t')
- Prod b x a t ->
- do a' <- co a
- t' <- co t
- return (Prod b x a' t')
- S c a ->
- do c' <- co c
- a' <- co a
- return (S c' a')
- Table a c ->
- do a' <- co a
- c' <- co c
- return (Table a' c')
- R r ->
- do r' <- mapAssignM co r
- return (R r')
- RecType r ->
- do r' <- mapPairListM (co . snd) r
- return (RecType r')
- P t i ->
- do t' <- co t
- return (P t' i)
- ExtR a c ->
- do a' <- co a
- c' <- co c
- return (ExtR a' c')
-
- T i cc ->
- do cc' <- mapPairListM (co . snd) cc
- i' <- changeTableType co i
- return (T i' cc')
-
- V ty vs ->
- do ty' <- co ty
- vs' <- mapM co vs
- return (V ty' vs')
-
- Let (x,(mt,a)) b ->
- do a' <- co a
- mt' <- case mt of
- Just t -> co t >>= (return . Just)
- _ -> return mt
- b' <- co b
- return (Let (x,(mt',a')) b')
-
- C s1 s2 ->
- do v1 <- co s1
- v2 <- co s2
- return (C v1 v2)
- Glue s1 s2 ->
- do v1 <- co s1
- v2 <- co s2
- return (Glue v1 v2)
- Alts (t,aa) ->
- do t' <- co t
- aa' <- mapM (pairM co) aa
- return (Alts (t',aa'))
- FV ts -> mapM co ts >>= return . FV
- Strs tt -> mapM co tt >>= return . Strs
-
- EPattType ty ->
- do ty' <- co ty
- return (EPattType ty')
-
- ELincat c ty ->
- do ty' <- co ty
- return (ELincat c ty')
-
- ELin c ty ->
- do ty' <- co ty
- return (ELin c ty')
-
- _ -> return trm -- covers K, Vr, Cn, Sort, EPatt
-
-getTableType :: TInfo -> Err Type
-getTableType i = case i of
- TTyped ty -> return ty
- TComp ty -> return ty
- TWild ty -> return ty
- _ -> Bad "the table is untyped"
-
-changeTableType :: Monad m => (Type -> m Type) -> TInfo -> m TInfo
-changeTableType co i = case i of
- TTyped ty -> co ty >>= return . TTyped
- TComp ty -> co ty >>= return . TComp
- TWild ty -> co ty >>= return . TWild
- _ -> return i
-
-collectOp :: (Term -> [a]) -> Term -> [a]
-collectOp co trm = case trm of
- App c a -> co c ++ co a
- Abs _ _ b -> co b
- Prod _ _ a b -> co a ++ co b
- S c a -> co c ++ co a
- Table a c -> co a ++ co c
- ExtR a c -> co a ++ co c
- R r -> concatMap (\ (_,(mt,a)) -> maybe [] co mt ++ co a) r
- RecType r -> concatMap (co . snd) r
- P t i -> co t
- T _ cc -> concatMap (co . snd) cc -- not from patterns --- nor from type annot
- V _ cc -> concatMap co cc --- nor from type annot
- Let (x,(mt,a)) b -> maybe [] co mt ++ co a ++ co b
- C s1 s2 -> co s1 ++ co s2
- Glue s1 s2 -> co s1 ++ co s2
- Alts (t,aa) -> let (x,y) = unzip aa in co t ++ concatMap co (x ++ y)
- FV ts -> concatMap co ts
- Strs tt -> concatMap co tt
- _ -> [] -- covers K, Vr, Cn, Sort
-
--- | to find the word items in a term
-wordsInTerm :: Term -> [String]
-wordsInTerm trm = filter (not . null) $ case trm of
- K s -> [s]
- S c _ -> wo c
- Alts (t,aa) -> wo t ++ concatMap (wo . fst) aa
- _ -> collectOp wo trm
- where wo = wordsInTerm
-
-noExist :: Term
-noExist = FV []
-
-defaultLinType :: Type
-defaultLinType = mkRecType linLabel [typeStr]
-
--- normalize records and record types; put s first
-
-sortRec :: [(Label,a)] -> [(Label,a)]
-sortRec = sortBy ordLabel where
- ordLabel (r1,_) (r2,_) =
- case (showIdent (label2ident r1), showIdent (label2ident r2)) of
- ("s",_) -> LT
- (_,"s") -> GT
- (s1,s2) -> compare s1 s2
-
--- | dependency check, detecting circularities and returning topo-sorted list
-
-allDependencies :: (Ident -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])]
-allDependencies ism b =
- [(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b]
- where
- opersIn t = case t of
- Q n c | ism n -> [c]
- QC n c | ism n -> [c]
- _ -> collectOp opersIn t
- opty (Just ty) = opersIn ty
- opty _ = []
- pts i = case i of
- ResOper pty pt -> [pty,pt]
- ResParam (Just ps) _ -> [Just t | (_,cont) <- ps, (_,_,t) <- cont]
- CncCat pty _ _ -> [pty]
- CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type))
- AbsFun pty _ ptr -> [pty] --- ptr is def, which can be mutual
- AbsCat (Just co) _ -> [Just ty | (_,_,ty) <- co]
- _ -> []
-
-topoSortJments :: SourceModule -> Err [(Ident,Info)]
-topoSortJments (m,mi) = do
- is <- either
- return
- (\cyc -> Bad (render (text "circular definitions:" <+> fsep (map ppIdent (head cyc)))))
- (topoTest (allDependencies (==m) (jments mi)))
- return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]])
diff --git a/src/GF/Grammar/Parser.y b/src/GF/Grammar/Parser.y
deleted file mode 100644
index 320053674..000000000
--- a/src/GF/Grammar/Parser.y
+++ /dev/null
@@ -1,739 +0,0 @@
-{
-{-# OPTIONS -fno-warn-overlapping-patterns #-}
-module GF.Grammar.Parser
- ( P, runP
- , pModDef
- , pModHeader
- , pExp
- ) where
-
-import GF.Infra.Ident
-import GF.Infra.Modules
-import GF.Infra.Option
-import GF.Data.Operations
-import GF.Grammar.Predef
-import GF.Grammar.Grammar
-import GF.Grammar.Macros
-import GF.Grammar.Lexer
-import qualified Data.ByteString.Char8 as BS
-import GF.Compile.Update (buildAnyTree)
-}
-
-%name pModDef ModDef
-%partial pModHeader ModHeader
-%name pExp Exp
-
--- no lexer declaration
-%monad { P } { >>= } { return }
-%lexer { lexer } { T_EOF }
-%tokentype { Token }
-
-
-%token
- '!' { T_exclmark }
- '#' { T_patt }
- '$' { T_int_label }
- '(' { T_oparen }
- ')' { T_cparen }
- '*' { T_star }
- '**' { T_starstar }
- '+' { T_plus }
- '++' { T_plusplus }
- ',' { T_comma }
- '-' { T_minus }
- '->' { T_rarrow }
- '.' { T_dot }
- '/' { T_alt }
- ':' { T_colon }
- ';' { T_semicolon }
- '<' { T_less }
- '=' { T_equal }
- '=>' { T_big_rarrow}
- '>' { T_great }
- '?' { T_questmark }
- '@' { T_at }
- '[' { T_obrack }
- ']' { T_cbrack }
- '{' { T_ocurly }
- '}' { T_ccurly }
- '\\' { T_lam }
- '\\\\' { T_lamlam }
- '_' { T_underscore}
- '|' { T_bar }
- 'PType' { T_PType }
- 'Str' { T_Str }
- 'Strs' { T_Strs }
- 'Tok' { T_Tok }
- 'Type' { T_Type }
- 'abstract' { T_abstract }
- 'case' { T_case }
- 'cat' { T_cat }
- 'concrete' { T_concrete }
- 'data' { T_data }
- 'def' { T_def }
- 'flags' { T_flags }
- 'fun' { T_fun }
- 'in' { T_in }
- 'incomplete' { T_incomplete}
- 'instance' { T_instance }
- 'interface' { T_interface }
- 'let' { T_let }
- 'lin' { T_lin }
- 'lincat' { T_lincat }
- 'lindef' { T_lindef }
- 'of' { T_of }
- 'open' { T_open }
- 'oper' { T_oper }
- 'param' { T_param }
- 'pattern' { T_pattern }
- 'pre' { T_pre }
- 'printname' { T_printname }
- 'resource' { T_resource }
- 'strs' { T_strs }
- 'table' { T_table }
- 'variants' { T_variants }
- 'where' { T_where }
- 'with' { T_with }
-
-Integer { (T_Integer $$) }
-Double { (T_Double $$) }
-String { (T_String $$) }
-LString { (T_LString $$) }
-Ident { (T_Ident $$) }
-
-
-%%
-
-ModDef :: { SourceModule }
-ModDef
- : ComplMod ModType '=' ModBody {%
- do let mstat = $1
- (mtype,id) = $2
- (extends,with,content) = $4
- (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
- mapM_ (checkInfoType mtype) jments
- defs <- case buildAnyTree id [(i,d) | (i,_,d) <- jments] of
- Ok x -> return x
- Bad msg -> fail msg
- let poss = buildTree [(i,(fname,mkSrcSpan p)) | (i,p,_) <- jments]
- fname = showIdent id ++ ".gf"
-
- mkSrcSpan :: (Posn, Posn) -> (Int,Int)
- mkSrcSpan (Pn l1 _, Pn l2 _) = (l1,l2)
-
- return (id, ModInfo mtype mstat opts extends with opens [] defs poss) }
-
-ModHeader :: { SourceModule }
-ModHeader
- : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
- (mtype,id) = $2 ;
- (extends,with,opens) = $4 }
- in (id, ModInfo mtype mstat noOptions extends with opens [] emptyBinTree emptyBinTree) }
-
-ComplMod :: { ModuleStatus }
-ComplMod
- : {- empty -} { MSComplete }
- | 'incomplete' { MSIncomplete }
-
-ModType :: { (ModuleType Ident,Ident) }
-ModType
- : 'abstract' Ident { (MTAbstract, $2) }
- | 'resource' Ident { (MTResource, $2) }
- | 'interface' Ident { (MTInterface, $2) }
- | 'concrete' Ident 'of' Ident { (MTConcrete $4, $2) }
- | 'instance' Ident 'of' Ident { (MTInstance $4, $2) }
-
-ModHeaderBody :: { ( [(Ident,MInclude Ident)]
- , Maybe (Ident,MInclude Ident,[(Ident,Ident)])
- , [OpenSpec Ident]
- ) }
-ModHeaderBody
- : ListIncluded '**' Included 'with' ListInst '**' ModOpen { ($1, Just (fst $3,snd $3,$5), $7) }
- | ListIncluded '**' Included 'with' ListInst { ($1, Just (fst $3,snd $3,$5), []) }
- | ListIncluded '**' ModOpen { ($1, Nothing, $3) }
- | ListIncluded { ($1, Nothing, []) }
- | Included 'with' ListInst '**' ModOpen { ([], Just (fst $1,snd $1,$3), $5) }
- | Included 'with' ListInst { ([], Just (fst $1,snd $1,$3), []) }
- | ModOpen { ([], Nothing, $1) }
-
-ModOpen :: { [OpenSpec Ident] }
-ModOpen
- : { [] }
- | 'open' ListOpen { $2 }
-
-ModBody :: { ( [(Ident,MInclude Ident)]
- , Maybe (Ident,MInclude Ident,[(Ident,Ident)])
- , Maybe ([OpenSpec Ident],[(Ident,SrcSpan,Info)],Options)
- ) }
-ModBody
- : ListIncluded '**' Included 'with' ListInst '**' ModContent { ($1, Just (fst $3,snd $3,$5), Just $7) }
- | ListIncluded '**' Included 'with' ListInst { ($1, Just (fst $3,snd $3,$5), Nothing) }
- | ListIncluded '**' ModContent { ($1, Nothing, Just $3) }
- | ListIncluded { ($1, Nothing, Nothing) }
- | Included 'with' ListInst '**' ModContent { ([], Just (fst $1,snd $1,$3), Just $5) }
- | Included 'with' ListInst { ([], Just (fst $1,snd $1,$3), Nothing) }
- | ModContent { ([], Nothing, Just $1) }
- | ModBody ';' { $1 }
-
-ModContent :: { ([OpenSpec Ident],[(Ident,SrcSpan,Info)],Options) }
-ModContent
- : '{' ListTopDef '}' { ([],[d | Left ds <- $2, d <- ds],concatOptions [o | Right o <- $2]) }
- | 'open' ListOpen 'in' '{' ListTopDef '}' { ($2,[d | Left ds <- $5, d <- ds],concatOptions [o | Right o <- $5]) }
-
-ListTopDef :: { [Either [(Ident,SrcSpan,Info)] Options] }
-ListTopDef
- : {- empty -} { [] }
- | TopDef ListTopDef { $1 : $2 }
-
-ListOpen :: { [OpenSpec Ident] }
-ListOpen
- : Open { [$1] }
- | Open ',' ListOpen { $1 : $3 }
-
-Open :: { OpenSpec Ident }
-Open
- : Ident { OSimple $1 }
- | '(' Ident '=' Ident ')' { OQualif $2 $4 }
-
-ListInst :: { [(Ident,Ident)] }
-ListInst
- : Inst { [$1] }
- | Inst ',' ListInst { $1 : $3 }
-
-Inst :: { (Ident,Ident) }
-Inst
- : '(' Ident '=' Ident ')' { ($2,$4) }
-
-ListIncluded :: { [(Ident,MInclude Ident)] }
-ListIncluded
- : Included { [$1] }
- | Included ',' ListIncluded { $1 : $3 }
-
-Included :: { (Ident,MInclude Ident) }
-Included
- : Ident { ($1,MIAll ) }
- | Ident '[' ListIdent ']' { ($1,MIOnly $3) }
- | Ident '-' '[' ListIdent ']' { ($1,MIExcept $4) }
-
-TopDef :: { Either [(Ident,SrcSpan,Info)] Options }
-TopDef
- : 'cat' ListCatDef { Left $2 }
- | 'fun' ListFunDef { Left $2 }
- | 'def' ListDefDef { Left $2 }
- | 'data' ListDataDef { Left $2 }
- | 'param' ListParamDef { Left $2 }
- | 'oper' ListOperDef { Left $2 }
- | 'lincat' ListTermDef { Left [(f, pos, CncCat (Just e) Nothing Nothing ) | (f,pos,e) <- $2] }
- | 'lindef' ListTermDef { Left [(f, pos, CncCat Nothing (Just e) Nothing ) | (f,pos,e) <- $2] }
- | 'lin' ListLinDef { Left $2 }
- | 'printname' 'cat' ListTermDef { Left [(f, pos, CncCat Nothing Nothing (Just e)) | (f,pos,e) <- $3] }
- | 'printname' 'fun' ListTermDef { Left [(f, pos, CncFun Nothing Nothing (Just e)) | (f,pos,e) <- $3] }
- | 'flags' ListFlagDef { Right $2 }
-
-CatDef :: { [(Ident,SrcSpan,Info)] }
-CatDef
- : Posn Ident ListDDecl Posn { [($2, ($1,$4), AbsCat (Just $3) Nothing)] }
- | Posn '[' Ident ListDDecl ']' Posn { listCatDef $3 ($1,$6) $4 0 }
- | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef $3 ($1,$9) $4 (fromIntegral $7) }
-
-FunDef :: { [(Ident,SrcSpan,Info)] }
-FunDef
- : Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) Nothing (Just [])) | fun <- $2] }
-
-DefDef :: { [(Ident,SrcSpan,Info)] }
-DefDef
- : Posn ListName '=' Exp Posn { [(f, ($1,$5),AbsFun Nothing (Just 0) (Just [([],$4)])) | f <- $2] }
- | Posn Name ListPatt '=' Exp Posn { [($2,($1,$6),AbsFun Nothing (Just (length $3)) (Just [($3,$5)]))] }
-
-DataDef :: { [(Ident,SrcSpan,Info)] }
-DataDef
- : Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing (Just (map Cn $4))) :
- [(fun, ($1,$5), AbsFun Nothing Nothing Nothing) | fun <- $4] }
- | Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), ($1,$5), AbsCat Nothing (Just (map Cn $2))) :
- [(fun, ($1,$5), AbsFun (Just $4) Nothing Nothing) | fun <- $2] }
-
-ParamDef :: { [(Ident,SrcSpan,Info)] }
-ParamDef
- : Posn Ident '=' ListParConstr Posn { ($2, ($1,$5), ResParam (Just $4) Nothing) :
- [(f, ($1,$5), ResValue (mkProdSimple co (Cn $2))) | (f,co) <- $4] }
- | Posn Ident Posn { [($2, ($1,$3), ResParam Nothing Nothing)] }
-
-OperDef :: { [(Ident,SrcSpan,Info)] }
-OperDef
- : Posn ListName ':' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload (Just $4) Nothing ] }
- | Posn ListName '=' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload Nothing (Just $4)] }
- | Posn Name ListArg '=' Exp Posn { [(i, ($1,$6), info) | i <- [$2], info <- mkOverload Nothing (Just (mkAbs $3 $5))] }
- | Posn ListName ':' Exp '=' Exp Posn { [(i, ($1,$7), info) | i <- $2, info <- mkOverload (Just $4) (Just $6)] }
-
-LinDef :: { [(Ident,SrcSpan,Info)] }
-LinDef
- : Posn ListName '=' Exp Posn { [(f, ($1,$5), CncFun Nothing (Just $4) Nothing) | f <- $2] }
- | Posn Name ListArg '=' Exp Posn { [($2, ($1,$6), CncFun Nothing (Just (mkAbs $3 $5)) Nothing)] }
-
-TermDef :: { [(Ident,SrcSpan,Term)] }
-TermDef
- : Posn ListName '=' Exp Posn { [(i,($1,$5),$4) | i <- $2] }
-
-FlagDef :: { Options }
-FlagDef
- : Posn Ident '=' Ident Posn {% case parseModuleOptions ["--" ++ showIdent $2 ++ "=" ++ showIdent $4] of
- Ok x -> return x
- Bad msg -> failLoc $1 msg }
-
-ListDataConstr :: { [Ident] }
-ListDataConstr
- : Ident { [$1] }
- | Ident '|' ListDataConstr { $1 : $3 }
-
-ParConstr :: { Param }
-ParConstr
- : Ident ListDDecl { ($1,$2) }
-
-ListLinDef :: { [(Ident,SrcSpan,Info)] }
-ListLinDef
- : LinDef ';' { $1 }
- | LinDef ';' ListLinDef { $1 ++ $3 }
-
-ListDefDef :: { [(Ident,SrcSpan,Info)] }
-ListDefDef
- : DefDef ';' { $1 }
- | DefDef ';' ListDefDef { $1 ++ $3 }
-
-ListOperDef :: { [(Ident,SrcSpan,Info)] }
-ListOperDef
- : OperDef ';' { $1 }
- | OperDef ';' ListOperDef { $1 ++ $3 }
-
-ListCatDef :: { [(Ident,SrcSpan,Info)] }
-ListCatDef
- : CatDef ';' { $1 }
- | CatDef ';' ListCatDef { $1 ++ $3 }
-
-ListFunDef :: { [(Ident,SrcSpan,Info)] }
-ListFunDef
- : FunDef ';' { $1 }
- | FunDef ';' ListFunDef { $1 ++ $3 }
-
-ListDataDef :: { [(Ident,SrcSpan,Info)] }
-ListDataDef
- : DataDef ';' { $1 }
- | DataDef ';' ListDataDef { $1 ++ $3 }
-
-ListParamDef :: { [(Ident,SrcSpan,Info)] }
-ListParamDef
- : ParamDef ';' { $1 }
- | ParamDef ';' ListParamDef { $1 ++ $3 }
-
-ListTermDef :: { [(Ident,SrcSpan,Term)] }
-ListTermDef
- : TermDef ';' { $1 }
- | TermDef ';' ListTermDef { $1 ++ $3 }
-
-ListFlagDef :: { Options }
-ListFlagDef
- : FlagDef ';' { $1 }
- | FlagDef ';' ListFlagDef { addOptions $1 $3 }
-
-ListParConstr :: { [Param] }
-ListParConstr
- : ParConstr { [$1] }
- | ParConstr '|' ListParConstr { $1 : $3 }
-
-ListIdent :: { [Ident] }
-ListIdent
- : Ident { [$1] }
- | Ident ',' ListIdent { $1 : $3 }
-
-ListIdent2 :: { [Ident] }
-ListIdent2
- : Ident { [$1] }
- | Ident ListIdent2 { $1 : $2 }
-
-Name :: { Ident }
-Name
- : Ident { $1 }
- | '[' Ident ']' { mkListId $2 }
-
-ListName :: { [Ident] }
-ListName
- : Name { [$1] }
- | Name ',' ListName { $1 : $3 }
-
-LocDef :: { [(Ident, Maybe Type, Maybe Term)] }
-LocDef
- : ListIdent ':' Exp { [(lab,Just $3,Nothing) | lab <- $1] }
- | ListIdent '=' Exp { [(lab,Nothing,Just $3) | lab <- $1] }
- | ListIdent ':' Exp '=' Exp { [(lab,Just $3,Just $5) | lab <- $1] }
-
-ListLocDef :: { [(Ident, Maybe Type, Maybe Term)] }
-ListLocDef
- : {- empty -} { [] }
- | LocDef { $1 }
- | LocDef ';' ListLocDef { $1 ++ $3 }
-
-Exp :: { Term }
-Exp
- : Exp1 '|' Exp { FV [$1,$3] }
- | '\\' ListBind '->' Exp { mkAbs $2 $4 }
- | '\\\\' ListBind '=>' Exp { mkCTable $2 $4 }
- | Decl '->' Exp { mkProdSimple $1 $3 }
- | Exp3 '=>' Exp { Table $1 $3 }
- | 'let' '{' ListLocDef '}' 'in' Exp {%
- do defs <- mapM tryLoc $3
- return $ mkLet defs $6 }
- | 'let' ListLocDef 'in' Exp {%
- do defs <- mapM tryLoc $2
- return $ mkLet defs $4 }
- | Exp3 'where' '{' ListLocDef '}' {%
- do defs <- mapM tryLoc $4
- return $ mkLet defs $1 }
- | 'in' Exp5 String { Example $2 $3 }
- | Exp1 { $1 }
-
-Exp1 :: { Term }
-Exp1
- : Exp2 '++' Exp1 { C $1 $3 }
- | Exp2 { $1 }
-
-Exp2 :: { Term }
-Exp2
- : Exp3 '+' Exp2 { Glue $1 $3 }
- | Exp3 { $1 }
-
-Exp3 :: { Term }
-Exp3
- : Exp3 '!' Exp4 { S $1 $3 }
- | 'table' '{' ListCase '}' { T TRaw $3 }
- | 'table' Exp6 '{' ListCase '}' { T (TTyped $2) $4 }
- | 'table' Exp6 '[' ListExp ']' { V $2 $4 }
- | Exp3 '*' Exp4 { case $1 of
- RecType xs -> RecType (xs ++ [(tupleLabel (length xs+1),$3)])
- t -> RecType [(tupleLabel 1,$1), (tupleLabel 2,$3)] }
- | Exp3 '**' Exp4 { ExtR $1 $3 }
- | Exp4 { $1 }
-
-Exp4 :: { Term }
-Exp4
- : Exp4 Exp5 { App $1 $2 }
- | Exp4 '{' Exp '}' { App $1 (ImplArg $3) }
- | 'case' Exp 'of' '{' ListCase '}' { let annot = case $2 of
- Typed _ t -> TTyped t
- _ -> TRaw
- in S (T annot $5) $2 }
- | 'variants' '{' ListExp '}' { FV $3 }
- | 'pre' '{' ListCase '}' {% mkAlts $3 }
- | 'pre' '{' String ';' ListAltern '}' { Alts (K $3, $5) }
- | 'pre' '{' Ident ';' ListAltern '}' { Alts (Vr $3, $5) }
- | 'strs' '{' ListExp '}' { Strs $3 }
- | '#' Patt2 { EPatt $2 }
- | 'pattern' Exp5 { EPattType $2 }
- | 'lincat' Ident Exp5 { ELincat $2 $3 }
- | 'lin' Ident Exp5 { ELin $2 $3 }
- | Exp5 { $1 }
-
-Exp5 :: { Term }
-Exp5
- : Exp5 '.' Label { P $1 $3 }
- | Exp6 { $1 }
-
-Exp6 :: { Term }
-Exp6
- : Ident { Vr $1 }
- | Sort { Sort $1 }
- | String { K $1 }
- | Integer { EInt $1 }
- | Double { EFloat $1 }
- | '?' { Meta 0 }
- | '[' ']' { Empty }
- | '[' Ident Exps ']' { foldl App (Vr (mkListId $2)) $3 }
- | '[' String ']' { case $2 of
- [] -> Empty
- str -> foldr1 C (map K (words str)) }
- | '{' ListLocDef '}' {% mkR $2 }
- | '<' ListTupleComp '>' { R (tuple2record $2) }
- | '<' Exp ':' Exp '>' { Typed $2 $4 }
- | LString { K $1 }
- | '(' Exp ')' { $2 }
-
-ListExp :: { [Term] }
-ListExp
- : {- empty -} { [] }
- | Exp { [$1] }
- | Exp ';' ListExp { $1 : $3 }
-
-Exps :: { [Term] }
-Exps
- : {- empty -} { [] }
- | Exp6 Exps { $1 : $2 }
-
-Patt :: { Patt }
-Patt
- : Patt '|' Patt1 { PAlt $1 $3 }
- | Patt '+' Patt1 { PSeq $1 $3 }
- | Patt1 { $1 }
-
-Patt1 :: { Patt }
-Patt1
- : Ident ListPatt { PC $1 $2 }
- | Ident '.' Ident ListPatt { PP $1 $3 $4 }
- | Patt2 '*' { PRep $1 }
- | Ident '@' Patt2 { PAs $1 $3 }
- | '-' Patt2 { PNeg $2 }
- | Patt2 { $1 }
-
-Patt2 :: { Patt }
-Patt2
- : '?' { PChar }
- | '[' String ']' { PChars $2 }
- | '#' Ident { PMacro $2 }
- | '#' Ident '.' Ident { PM $2 $4 }
- | '_' { PW }
- | Ident { PV $1 }
- | Ident '.' Ident { PP $1 $3 [] }
- | Integer { PInt $1 }
- | Double { PFloat $1 }
- | String { PString $1 }
- | '{' ListPattAss '}' { PR $2 }
- | '<' ListPattTupleComp '>' { (PR . tuple2recordPatt) $2 }
- | '(' Patt ')' { $2 }
-
-PattAss :: { [(Label,Patt)] }
-PattAss
- : ListIdent '=' Patt { [(LIdent (ident2bs i),$3) | i <- $1] }
-
-Label :: { Label }
-Label
- : Ident { LIdent (ident2bs $1) }
- | '$' Integer { LVar (fromIntegral $2) }
-
-Sort :: { Ident }
-Sort
- : 'Type' { cType }
- | 'PType' { cPType }
- | 'Tok' { cTok }
- | 'Str' { cStr }
- | 'Strs' { cStrs }
-
-ListPattAss :: { [(Label,Patt)] }
-ListPattAss
- : {- empty -} { [] }
- | PattAss { $1 }
- | PattAss ';' ListPattAss { $1 ++ $3 }
-
-ListPatt :: { [Patt] }
-ListPatt
- : PattArg { [$1] }
- | PattArg ListPatt { $1 : $2 }
-
-PattArg :: { Patt }
- : Patt2 { $1 }
- | '{' Patt2 '}' { PImplArg $2 }
-
-Arg :: { [(BindType,Ident)] }
-Arg
- : Ident { [(Explicit,$1 )] }
- | '_' { [(Explicit,identW)] }
- | '{' ListIdent2 '}' { [(Implicit,v) | v <- $2] }
-
-ListArg :: { [(BindType,Ident)] }
-ListArg
- : Arg { $1 }
- | Arg ListArg { $1 ++ $2 }
-
-Bind :: { [(BindType,Ident)] }
-Bind
- : Ident { [(Explicit,$1 )] }
- | '_' { [(Explicit,identW)] }
- | '{' ListIdent '}' { [(Implicit,v) | v <- $2] }
-
-ListBind :: { [(BindType,Ident)] }
-ListBind
- : Bind { $1 }
- | Bind ',' ListBind { $1 ++ $3 }
-
-Decl :: { [Hypo] }
-Decl
- : '(' ListBind ':' Exp ')' { [(b,x,$4) | (b,x) <- $2] }
- | Exp4 { [mkHypo $1] }
-
-ListTupleComp :: { [Term] }
-ListTupleComp
- : {- empty -} { [] }
- | Exp { [$1] }
- | Exp ',' ListTupleComp { $1 : $3 }
-
-ListPattTupleComp :: { [Patt] }
-ListPattTupleComp
- : {- empty -} { [] }
- | Patt { [$1] }
- | Patt ',' ListPattTupleComp { $1 : $3 }
-
-Case :: { Case }
-Case
- : Patt '=>' Exp { ($1,$3) }
-
-ListCase :: { [Case] }
-ListCase
- : Case { [$1] }
- | Case ';' ListCase { $1 : $3 }
-
-Altern :: { (Term,Term) }
-Altern
- : Exp '/' Exp { ($1,$3) }
-
-ListAltern :: { [(Term,Term)] }
-ListAltern
- : Altern { [$1] }
- | Altern ';' ListAltern { $1 : $3 }
-
-DDecl :: { [Hypo] }
-DDecl
- : '(' ListBind ':' Exp ')' { [(b,x,$4) | (b,x) <- $2] }
- | Exp6 { [mkHypo $1] }
-
-ListDDecl :: { [Hypo] }
-ListDDecl
- : {- empty -} { [] }
- | DDecl ListDDecl { $1 ++ $2 }
-
-Posn :: { Posn }
-Posn
- : {- empty -} {% getPosn }
-
-
-{
-
-happyError :: P a
-happyError = fail "parse error"
-
-mkListId,mkConsId,mkBaseId :: Ident -> Ident
-mkListId = prefixId (BS.pack "List")
-mkConsId = prefixId (BS.pack "Cons")
-mkBaseId = prefixId (BS.pack "Base")
-
-prefixId :: BS.ByteString -> Ident -> Ident
-prefixId pref id = identC (BS.append pref (ident2bs id))
-
-listCatDef :: Ident -> SrcSpan -> Context -> Int -> [(Ident,SrcSpan,Info)]
-listCatDef id pos cont size = [catd,nilfund,consfund]
- where
- listId = mkListId id
- baseId = mkBaseId id
- consId = mkConsId id
-
- catd = (listId, pos, AbsCat (Just cont') (Just [Cn baseId,Cn consId]))
- nilfund = (baseId, pos, AbsFun (Just niltyp) Nothing Nothing)
- consfund = (consId, pos, AbsFun (Just constyp) Nothing Nothing)
-
- cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont]
- xs = map (\(b,x,t) -> Vr x) cont'
- cd = mkHypo (mkApp (Vr id) xs)
- lc = mkApp (Vr listId) xs
-
- niltyp = mkProdSimple (cont' ++ replicate size cd) lc
- constyp = mkProdSimple (cont' ++ [cd, mkHypo lc]) lc
-
- mkId x i = if isWildIdent x then (varX i) else x
-
-tryLoc (c,mty,Just e) = return (c,(mty,e))
-tryLoc (c,_ ,_ ) = fail ("local definition of" +++ showIdent c +++ "without value")
-
-mkR [] = return $ RecType [] --- empty record always interpreted as record type
-mkR fs@(f:_) =
- case f of
- (lab,Just ty,Nothing) -> mapM tryRT fs >>= return . RecType
- _ -> mapM tryR fs >>= return . R
- where
- tryRT (lab,Just ty,Nothing) = return (ident2label lab,ty)
- tryRT (lab,_ ,_ ) = fail $ "illegal record type field" +++ showIdent lab --- manifest fields ?!
-
- tryR (lab,mty,Just t) = return (ident2label lab,(mty,t))
- tryR (lab,_ ,_ ) = fail $ "illegal record field" +++ showIdent lab
-
-mkOverload pdt pdf@(Just df) =
- case appForm df of
- (keyw, ts@(_:_)) | isOverloading keyw ->
- case last ts of
- R fs -> [ResOverload [m | Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs]]
- _ -> [ResOper pdt pdf]
- _ -> [ResOper pdt pdf]
-
- -- to enable separare type signature --- not type-checked
-mkOverload pdt@(Just df) pdf =
- case appForm df of
- (keyw, ts@(_:_)) | isOverloading keyw ->
- case last ts of
- RecType _ -> []
- _ -> [ResOper pdt pdf]
- _ -> [ResOper pdt pdf]
-mkOverload pdt pdf = [ResOper pdt pdf]
-
-isOverloading t =
- case t of
- Vr keyw | showIdent keyw == "overload" -> True -- overload is a "soft keyword"
- _ -> False
-
-
-type SrcSpan = (Posn,Posn)
-
-
-checkInfoType MTAbstract (id,pos,info) =
- case info of
- AbsCat _ _ -> return ()
- AbsFun _ _ _ -> return ()
- _ -> failLoc (fst pos) "illegal definition in abstract module"
-checkInfoType MTResource (id,pos,info) =
- case info of
- ResParam _ _ -> return ()
- ResValue _ -> return ()
- ResOper _ _ -> return ()
- ResOverload _ _ -> return ()
- _ -> failLoc (fst pos) "illegal definition in resource module"
-checkInfoType MTInterface (id,pos,info) =
- case info of
- ResParam _ _ -> return ()
- ResValue _ -> return ()
- ResOper _ _ -> return ()
- ResOverload _ _ -> return ()
- _ -> failLoc (fst pos) "illegal definition in interface module"
-checkInfoType (MTConcrete _) (id,pos,info) =
- case info of
- CncCat _ _ _ -> return ()
- CncFun _ _ _ -> return ()
- ResParam _ _ -> return ()
- ResValue _ -> return ()
- ResOper _ _ -> return ()
- ResOverload _ _ -> return ()
- _ -> failLoc (fst pos) "illegal definition in concrete module"
-checkInfoType (MTInstance _) (id,pos,info) =
- case info of
- ResParam _ _ -> return ()
- ResValue _ -> return ()
- ResOper _ _ -> return ()
- _ -> failLoc (fst pos) "illegal definition in instance module"
-
-
-mkAlts cs = case cs of
- _:_ -> do
- def <- mkDef (last cs)
- alts <- mapM mkAlt (init cs)
- return (Alts (def,alts))
- _ -> fail "empty alts"
- where
- mkDef (_,t) = return t
- mkAlt (p,t) = do
- ss <- mkStrs p
- return (t,ss)
- mkStrs p = case p of
- PAlt a b -> do
- Strs as <- mkStrs a
- Strs bs <- mkStrs b
- return $ Strs $ as ++ bs
- PString s -> return $ Strs [K s]
- PV x -> return (Vr x) --- for macros; not yet complete
- PMacro x -> return (Vr x) --- for macros; not yet complete
- PM m c -> return (Q m c) --- for macros; not yet complete
- _ -> fail "no strs from pattern"
-
-}
-
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
deleted file mode 100644
index b8f7eff7d..000000000
--- a/src/GF/Grammar/PatternMatch.hs
+++ /dev/null
@@ -1,165 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : PatternMatch
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > 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
- ) where
-
-import GF.Data.Operations
-import GF.Grammar.Grammar
-import GF.Infra.Ident
-import GF.Grammar.Macros
-import GF.Grammar.Printer
-
-import Data.List
-import Control.Monad
-import Text.PrettyPrint
-import Debug.Trace
-
-matchPattern :: [(Patt,Term)] -> Term -> Err (Term, Substitution)
-matchPattern pts term =
- if not (isInConstantForm term)
- then Bad (render (text "variables occur in" <+> ppTerm Unqualified 0 term))
- else do
- term' <- mkK term
- errIn (render (text "trying patterns" <+> hsep (punctuate comma (map (ppPatt Unqualified 0 . fst) pts)))) $
- findMatch [([p],t) | (p,t) <- pts] [term']
- where
- -- to capture all Str with string pattern matching
- mkK s = case s of
- C _ _ -> do
- s' <- getS s
- return (K (unwords s'))
- _ -> return s
-
- getS s = case s of
- K w -> return [w]
- C v w -> liftM2 (++) (getS v) (getS w)
- Empty -> return []
- _ -> Bad (render (text "cannot get string from" <+> ppTerm Unqualified 0 s))
-
-testOvershadow :: [Patt] -> [Term] -> Err [Patt]
-testOvershadow pts vs = do
- let numpts = zip pts [0..]
- let cases = [(p,EInt i) | (p,i) <- numpts]
- ts <- mapM (liftM fst . matchPattern cases) vs
- return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ]
-
-findMatch :: [([Patt],Term)] -> [Term] -> Err (Term, Substitution)
-findMatch cases terms = case cases of
- [] -> Bad (render (text "no applicable case for" <+> hsep (punctuate comma (map (ppTerm Unqualified 0) terms))))
- (patts,_):_ | length patts /= length terms ->
- Bad (render (text "wrong number of args for patterns :" <+> hsep (map (ppPatt Unqualified 0) patts) <+>
- text "cannot take" <+> hsep (map (ppTerm Unqualified 0) 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
- t' <- termForm t
- trym p t'
- where
-
- isInConstantFormt = True -- tested already in matchPattern
- trym p t' =
- case (p,t') of
- (_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = []
- (PW, _) | isInConstantFormt -> return [] -- optimization with wildcard
- (PV x, _) | isInConstantFormt -> return [(x,t)]
- (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)) |
- 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)) |
- -- 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 && ---
- 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
- [(p,snd a) | (l,p) <- r, let Just a = lookup l r']
- return (concat matches)
- (PT _ p',_) -> trym p' t'
-
- (PAs x p',_) -> do
- subst <- trym p' t'
- return $ (x,t) : subst
-
- (PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t']
-
- (PNeg p',_) -> case tryMatch (p',t) of
- Bad _ -> return []
- _ -> Bad (render (text "no match with negative pattern" <+> ppPatt Unqualified 0 p))
-
- (PSeq p1 p2, ([],K s, [])) -> do
- let cuts = [splitAt n s | n <- [0 .. length s]]
- matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts]
- return (concat matches)
-
- (PRep p1, ([],K s, [])) -> checks [
- trym (foldr (const (PSeq p1)) (PString "")
- [1..n]) t' | n <- [0 .. length s]
- ] >>
- return []
-
- (PChar, ([],K [_], [])) -> return []
- (PChars cs, ([],K [c], [])) | elem c cs -> return []
-
- _ -> Bad (render (text "no match in case expr for" <+> ppTerm Unqualified 0 t))
-
-isInConstantForm :: Term -> Bool
-isInConstantForm trm = case trm of
- Cn _ -> True
- Con _ -> True
- Q _ _ -> True
- QC _ _ -> True
- Abs _ _ _ -> True
- C c a -> isInConstantForm c && isInConstantForm a
- App c a -> isInConstantForm c && isInConstantForm a
- R r -> all (isInConstantForm . snd . snd) r
- K _ -> True
- Empty -> True
- EInt _ -> True
- _ -> False ---- isInArgVarForm trm
-
-varsOfPatt :: Patt -> [Ident]
-varsOfPatt p = case p of
- PV x -> [x]
- PC _ ps -> concat $ map varsOfPatt ps
- PP _ _ ps -> concat $ map varsOfPatt ps
- PR r -> concat $ map (varsOfPatt . snd) r
- PT _ q -> varsOfPatt q
- _ -> []
-
--- | to search matching parameter combinations in tables
-isMatchingForms :: [Patt] -> [Term] -> Bool
-isMatchingForms ps ts = all match (zip ps ts') where
- match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds
- match _ = True
- ts' = map appForm ts
-
diff --git a/src/GF/Grammar/Predef.hs b/src/GF/Grammar/Predef.hs
deleted file mode 100644
index 045df06ca..000000000
--- a/src/GF/Grammar/Predef.hs
+++ /dev/null
@@ -1,180 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : GF.Grammar.Predef
--- Maintainer : kr.angelov
--- Stability : (stable)
--- Portability : (portable)
---
--- Predefined identifiers and labels which the compiler knows
-----------------------------------------------------------------------
-
-
-module GF.Grammar.Predef
- ( cType
- , cPType
- , cTok
- , cStr
- , cStrs
- , cPredefAbs, cPredefCnc, cPredef
- , cInt
- , cFloat
- , cString
- , cInts
- , cPBool
- , cErrorType
- , cOverload
- , cUndefinedType
- , isPredefCat
-
- , cPTrue, cPFalse
-
- , cLength, cDrop, cTake, cTk, cDp, cEqStr, cOccur
- , cOccurs, cEqInt, cLessInt, cPlus, cShow, cRead
- , cToStr, cMapStr, cError
-
- -- hacks
- , cMeta, cAs, cChar, cChars, cSeq, cAlt, cRep
- , cNeg, cCNC, cConflict
- ) where
-
-import GF.Infra.Ident
-import qualified Data.ByteString.Char8 as BS
-
-cType :: Ident
-cType = identC (BS.pack "Type")
-
-cPType :: Ident
-cPType = identC (BS.pack "PType")
-
-cTok :: Ident
-cTok = identC (BS.pack "Tok")
-
-cStr :: Ident
-cStr = identC (BS.pack "Str")
-
-cStrs :: Ident
-cStrs = identC (BS.pack "Strs")
-
-cPredefAbs :: Ident
-cPredefAbs = identC (BS.pack "PredefAbs")
-
-cPredefCnc :: Ident
-cPredefCnc = identC (BS.pack "PredefCnc")
-
-cPredef :: Ident
-cPredef = identC (BS.pack "Predef")
-
-cInt :: Ident
-cInt = identC (BS.pack "Int")
-
-cFloat :: Ident
-cFloat = identC (BS.pack "Float")
-
-cString :: Ident
-cString = identC (BS.pack "String")
-
-cInts :: Ident
-cInts = identC (BS.pack "Ints")
-
-cPBool :: Ident
-cPBool = identC (BS.pack "PBool")
-
-cErrorType :: Ident
-cErrorType = identC (BS.pack "Error")
-
-cOverload :: Ident
-cOverload = identC (BS.pack "overload")
-
-cUndefinedType :: Ident
-cUndefinedType = identC (BS.pack "UndefinedType")
-
-isPredefCat :: Ident -> Bool
-isPredefCat c = elem c [cInt,cString,cFloat]
-
-cPTrue :: Ident
-cPTrue = identC (BS.pack "PTrue")
-
-cPFalse :: Ident
-cPFalse = identC (BS.pack "PFalse")
-
-cLength :: Ident
-cLength = identC (BS.pack "length")
-
-cDrop :: Ident
-cDrop = identC (BS.pack "drop")
-
-cTake :: Ident
-cTake = identC (BS.pack "take")
-
-cTk :: Ident
-cTk = identC (BS.pack "tk")
-
-cDp :: Ident
-cDp = identC (BS.pack "dp")
-
-cEqStr :: Ident
-cEqStr = identC (BS.pack "eqStr")
-
-cOccur :: Ident
-cOccur = identC (BS.pack "occur")
-
-cOccurs :: Ident
-cOccurs = identC (BS.pack "occurs")
-
-cEqInt :: Ident
-cEqInt = identC (BS.pack "eqInt")
-
-cLessInt :: Ident
-cLessInt = identC (BS.pack "lessInt")
-
-cPlus :: Ident
-cPlus = identC (BS.pack "plus")
-
-cShow :: Ident
-cShow = identC (BS.pack "show")
-
-cRead :: Ident
-cRead = identC (BS.pack "read")
-
-cToStr :: Ident
-cToStr = identC (BS.pack "toStr")
-
-cMapStr :: Ident
-cMapStr = identC (BS.pack "mapStr")
-
-cError :: Ident
-cError = identC (BS.pack "error")
-
-
---- hacks: dummy identifiers used in various places
---- Not very nice!
-
-cMeta :: Ident
-cMeta = identC (BS.singleton '?')
-
-cAs :: Ident
-cAs = identC (BS.singleton '@')
-
-cChar :: Ident
-cChar = identC (BS.singleton '?')
-
-cChars :: Ident
-cChars = identC (BS.pack "[]")
-
-cSeq :: Ident
-cSeq = identC (BS.pack "+")
-
-cAlt :: Ident
-cAlt = identC (BS.pack "|")
-
-cRep :: Ident
-cRep = identC (BS.pack "*")
-
-cNeg :: Ident
-cNeg = identC (BS.pack "-")
-
-cCNC :: Ident
-cCNC = identC (BS.pack "CNC")
-
-cConflict :: Ident
-cConflict = IC (BS.pack "#conflict")
diff --git a/src/GF/Grammar/Printer.hs b/src/GF/Grammar/Printer.hs
deleted file mode 100644
index 06cac9705..000000000
--- a/src/GF/Grammar/Printer.hs
+++ /dev/null
@@ -1,317 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : GF.Grammar.Printer
--- Maintainer : Krasimir Angelov
--- Stability : (stable)
--- Portability : (portable)
---
------------------------------------------------------------------------------
-
-module GF.Grammar.Printer
- ( TermPrintQual(..)
- , ppIdent
- , ppLabel
- , ppModule
- , ppJudgement
- , ppTerm
- , ppTermTabular
- , ppPatt
- , ppValue
- , ppConstrs
-
- , showTerm, TermPrintStyle(..)
- ) where
-
-import GF.Infra.Ident
-import GF.Infra.Modules
-import GF.Infra.Option
-import GF.Grammar.Values
-import GF.Grammar.Grammar
-import GF.Data.Operations
-import Text.PrettyPrint
-
-import Data.Maybe (maybe)
-import Data.List (intersperse)
-
-data TermPrintQual = Qualified | Unqualified
-
-ppModule :: TermPrintQual -> SourceModule -> Doc
-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ jments _) =
- hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr
- where
- defs = tree2list jments
-
- hdr = complModDoc <+> modTypeDoc <+> equals <+>
- hsep (intersperse (text "**") $
- filter (not . isEmpty) $ [ commaPunct ppExtends exts
- , maybe empty ppWith with
- , if null opens
- then lbrace
- else text "open" <+> commaPunct ppOpenSpec opens <+> text "in" <+> lbrace
- ])
-
- ftr = rbrace
-
- complModDoc =
- case mstat of
- MSComplete -> empty
- MSIncomplete -> text "incomplete"
-
- modTypeDoc =
- case mtype of
- MTAbstract -> text "abstract" <+> ppIdent mn
- MTResource -> text "resource" <+> ppIdent mn
- MTConcrete abs -> text "concrete" <+> ppIdent mn <+> text "of" <+> ppIdent abs
- MTInterface -> text "interface" <+> ppIdent mn
- MTInstance int -> text "instance" <+> ppIdent mn <+> text "of" <+> ppIdent int
-
- ppExtends (id,MIAll ) = ppIdent id
- ppExtends (id,MIOnly incs) = ppIdent id <+> brackets (commaPunct ppIdent incs)
- ppExtends (id,MIExcept incs) = ppIdent id <+> char '-' <+> brackets (commaPunct ppIdent incs)
-
- ppWith (id,ext,opens) = ppExtends (id,ext) <+> text "with" <+> commaPunct ppInstSpec opens
-
-ppOptions opts =
- text "flags" $$
- nest 2 (vcat [text option <+> equals <+> str value <+> semi | (option,value) <- optionsGFO opts])
-
-ppJudgement q (id, AbsCat pcont pconstrs) =
- text "cat" <+> ppIdent id <+>
- (case pcont of
- Just cont -> hsep (map (ppDecl q) cont)
- Nothing -> empty) <+> semi $$
- case pconstrs of
- Just costrs -> text "data" <+> ppIdent id <+> equals <+> fsep (intersperse (char '|') (map (ppTerm q 0) costrs)) <+> semi
- Nothing -> empty
-ppJudgement q (id, AbsFun ptype _ pexp) =
- (case ptype of
- Just typ -> text "fun" <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi
- Nothing -> empty) $$
- (case pexp of
- Just [] -> empty
- Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | (ps,e) <- eqs]
- Nothing -> empty)
-ppJudgement q (id, ResParam pparams _) =
- text "param" <+> ppIdent id <+>
- (case pparams of
- Just ps -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps))
- _ -> empty) <+> semi
-ppJudgement q (id, ResValue pvalue) = empty
-ppJudgement q (id, ResOper ptype pexp) =
- text "oper" <+> ppIdent id <+>
- (case ptype of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} $$
- case pexp of {Just e -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi
-ppJudgement q (id, ResOverload ids defs) =
- text "oper" <+> ppIdent id <+> equals <+>
- (text "overload" <+> lbrace $$
- nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (ty,e) <- defs]) $$
- rbrace) <+> semi
-ppJudgement q (id, CncCat ptype pexp pprn) =
- (case ptype of
- Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi
- Nothing -> empty) $$
- (case pexp of
- Just exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
- Nothing -> empty) $$
- (case pprn of
- Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
- Nothing -> empty)
-ppJudgement q (id, CncFun ptype pdef pprn) =
- (case pdef of
- Just e -> let (xs,e') = getAbs e
- in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi
- Nothing -> empty) $$
- (case pprn of
- Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
- Nothing -> empty)
-ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi
-
-ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
- in prec d 0 (char '\\' <> commaPunct ppBind xs <+> text "->" <+> ppTerm q 0 e')
-ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
- ([],_) -> text "table" <+> lbrace $$
- nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
- rbrace
- (vs,e) -> prec d 0 (text "\\\\" <> commaPunct ppIdent vs <+> text "=>" <+> ppTerm q 0 e)
-ppTerm q d (T (TTyped t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$
- nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
- rbrace
-ppTerm q d (T (TComp t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$
- nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
- rbrace
-ppTerm q d (T (TWild t) xs) = text "table" <+> ppTerm q 0 t <+> lbrace $$
- nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
- rbrace
-ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
- then prec d 0 (ppTerm q 4 a <+> text "->" <+> ppTerm q 0 b)
- else prec d 0 (parens (ppBind (bt,x) <+> colon <+> ppTerm q 0 a) <+> text "->" <+> ppTerm q 0 b)
-ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> text "=>" <+> ppTerm q 0 vt)
-ppTerm q d (Let l e) = let (ls,e') = getLet e
- in prec d 0 (text "let" <+> vcat (map (ppLocDef q) (l:ls)) $$ text "in" <+> ppTerm q 0 e')
-ppTerm q d (Example e s)=prec d 0 (text "in" <+> ppTerm q 5 e <+> str s)
-ppTerm q d (C e1 e2) =prec d 1 (ppTerm q 2 e1 <+> text "++" <+> ppTerm q 1 e2)
-ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> char '+' <+> 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 text "case" <+> ppTerm q 0 e <+> text "of" <+> lbrace $$
- nest 2 (vcat (punctuate semi (map (ppCase q) xs))) $$
- rbrace
- _ -> prec d 3 (ppTerm q 3 x <+> text "!" <+> ppTerm q 4 y)
-ppTerm q d (ExtR x y) = prec d 3 (ppTerm q 3 x <+> text "**" <+> 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) = text "table" <+> ppTerm q 6 e <+> lbrace $$
- nest 2 (fsep (punctuate semi (map (ppTerm q 0) es))) $$
- rbrace
-ppTerm q d (FV es) = text "variants" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
-ppTerm q d (Alts (e,xs))=text "pre" <+> braces (ppTerm q 0 e <> semi <+> fsep (punctuate semi (map (ppAltern q) xs)))
-ppTerm q d (Strs es) = text "strs" <+> braces (fsep (punctuate semi (map (ppTerm q 0) es)))
-ppTerm q d (EPatt p) = prec d 4 (char '#' <+> ppPatt q 2 p)
-ppTerm q d (EPattType t)=prec d 4 (text "pattern" <+> ppTerm q 0 t)
-ppTerm q d (P t l) = prec d 5 (ppTerm q 5 t <> char '.' <> ppLabel l)
-ppTerm q d (Cn id) = ppIdent id
-ppTerm q d (Vr id) = ppIdent id
-ppTerm q d (Q m id) = ppQIdent q m id
-ppTerm q d (QC m id) = ppQIdent q m id
-ppTerm q d (Sort id) = ppIdent id
-ppTerm q d (K s) = str s
-ppTerm q d (EInt n) = integer n
-ppTerm q d (EFloat f) = double f
-ppTerm q d (Meta _) = char '?'
-ppTerm q d (Empty) = text "[]"
-ppTerm q d (R xs) = braces (fsep (punctuate semi [ppLabel l <+>
- fsep [case mb_t of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty},
- equals <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
-ppTerm q d (RecType xs)= braces (fsep (punctuate semi [ppLabel l <+> colon <+> ppTerm q 0 t | (l,t) <- xs]))
-ppTerm q d (Typed e t) = char '<' <> ppTerm q 0 e <+> colon <+> ppTerm q 0 t <> char '>'
-
-ppTermTabular :: TermPrintQual -> Term -> [(Doc,Doc)]
-ppTermTabular q = pr where
- pr t = case t of
- R rs ->
- [(ppLabel lab <+> char '.' <+> path, str) | (lab,(_,val)) <- rs, (path,str) <- pr val]
- T _ cs ->
- [(ppPatt q 0 patt <+> text "=>" <+> path, str) | (patt, val ) <- cs, (path,str) <- pr val]
- V _ cs ->
- [(char '#' <> int i <+> text "=>" <+> path, str) | (i, val ) <- zip [0..] cs, (path,str) <- pr val]
- _ -> [(empty,ps t)]
- ps t = case t of
- K s -> text s
- C s u -> ps s <+> ps u
- FV ts -> hsep (intersperse (char '/') (map ps ts))
- _ -> ppTerm q 0 t
-
-ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> text "->" <+> ppTerm q 0 e
-
-ppCase q (p,e) = ppPatt q 0 p <+> text "=>" <+> ppTerm q 0 e
-
-ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '|' <+> ppPatt q 1 p2)
-ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> char '+' <+> ppPatt q 1 p2)
-ppPatt q d (PC f ps) = if null ps
- then ppIdent f
- else prec d 1 (ppIdent f <+> hsep (map (ppPatt q 2) ps))
-ppPatt q d (PP f g ps) = if null ps
- then ppQIdent q f g
- else prec d 1 (ppQIdent q f g <+> hsep (map (ppPatt q 2) ps))
-ppPatt q d (PRep p) = prec d 1 (ppPatt q 2 p <> char '*')
-ppPatt q d (PAs f p) = prec d 1 (ppIdent f <> char '@' <> ppPatt q 2 p)
-ppPatt q d (PNeg p) = prec d 1 (char '-' <> ppPatt q 2 p)
-ppPatt q d (PChar) = char '?'
-ppPatt q d (PChars s) = brackets (str s)
-ppPatt q d (PMacro id) = char '#' <> ppIdent id
-ppPatt q d (PM m id) = char '#' <> ppIdent m <> char '.' <> ppIdent id
-ppPatt q d PW = char '_'
-ppPatt q d (PV id) = ppIdent id
-ppPatt q d (PInt n) = integer n
-ppPatt q d (PFloat f) = double f
-ppPatt q d (PString s) = str s
-ppPatt q d (PR xs) = braces (hsep (punctuate semi [ppLabel l <+> equals <+> ppPatt q 0 e | (l,e) <- xs]))
-
-ppValue :: TermPrintQual -> Int -> Val -> Doc
-ppValue q d (VGen i x) = ppIdent x <> text "{-" <> int i <> text "-}" ---- 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)) = ppIdent 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 comma [ppLabel l <> char '=' <> ppValue q 0 v | (l,v) <- xs]))
-ppValue q d VType = text "Type"
-
-ppConstrs :: Constraints -> [Doc]
-ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> text "<>" <+> ppValue Unqualified 0 w))
-
-ppEnv :: Env -> Doc
-ppEnv e = hcat (map (\(x,t) -> braces (ppIdent x <> text ":=" <> ppValue Unqualified 0 t)) e)
-
-str s = doubleQuotes (text s)
-
-ppDecl q (_,id,typ)
- | id == identW = ppTerm q 4 typ
- | otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)
-
-ppDDecl q (_,id,typ)
- | id == identW = ppTerm q 6 typ
- | otherwise = parens (ppIdent id <+> colon <+> ppTerm q 0 typ)
-
-ppIdent = text . showIdent
-
-ppQIdent q m id =
- case q of
- Qualified -> ppIdent m <> char '.' <> ppIdent id
- Unqualified -> ppIdent id
-
-ppLabel = ppIdent . label2ident
-
-ppOpenSpec (OSimple id) = ppIdent id
-ppOpenSpec (OQualif id n) = parens (ppIdent id <+> equals <+> ppIdent n)
-
-ppInstSpec (id,n) = parens (ppIdent id <+> equals <+> ppIdent n)
-
-ppLocDef q (id, (mbt, e)) =
- ppIdent id <+>
- (case mbt of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} <+> equals <+> ppTerm q 0 e) <+> semi
-
-ppBind (Explicit,v) = ppIdent v
-ppBind (Implicit,v) = braces (ppIdent v)
-
-ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y
-
-ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
-
-commaPunct f ds = (hcat (punctuate comma (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)
-
-showTerm :: TermPrintStyle -> TermPrintQual -> Term -> String
-showTerm style q t = render $
- case style of
- TermPrintTable -> vcat [p <+> s | (p,s) <- ppTermTabular q t]
- TermPrintAll -> vcat [ s | (p,s) <- ppTermTabular q t]
- TermPrintDefault -> ppTerm q 0 t
-
-data TermPrintStyle
- = TermPrintTable
- | TermPrintAll
- | TermPrintDefault
diff --git a/src/GF/Grammar/Unify.hs b/src/GF/Grammar/Unify.hs
deleted file mode 100644
index 9bb49cfe2..000000000
--- a/src/GF/Grammar/Unify.hs
+++ /dev/null
@@ -1,97 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Unify
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:31 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.4 $
---
--- (c) Petri Mäenpää & Aarne Ranta, 1998--2001
---
--- brute-force adaptation of the old-GF program AR 21\/12\/2001 ---
--- the only use is in 'TypeCheck.splitConstraints'
------------------------------------------------------------------------------
-
-module GF.Grammar.Unify (unifyVal) where
-
-import GF.Grammar
-import GF.Data.Operations
-
-import Text.PrettyPrint
-import Data.List (partition)
-
-unifyVal :: Constraints -> Err (Constraints,MetaSubst)
-unifyVal cs0 = do
- let (cs1,cs2) = partition notSolvable cs0
- let (us,vs) = unzip cs2
- us' <- mapM val2exp us
- vs' <- mapM val2exp vs
- let (ms,cs) = unifyAll (zip us' vs') []
- return (cs1 ++ [(VClos [] t, VClos [] u) | (t,u) <- cs],
- [(m, VClos [] t) | (m,t) <- ms])
- where
- notSolvable (v,w) = case (v,w) of -- don't consider nonempty closures
- (VClos (_:_) _,_) -> True
- (_,VClos (_:_) _) -> True
- _ -> False
-
-type Unifier = [(MetaId, Term)]
-type Constrs = [(Term, Term)]
-
-unifyAll :: Constrs -> Unifier -> (Unifier,Constrs)
-unifyAll [] g = (g, [])
-unifyAll ((a@(s, t)) : l) g =
- let (g1, c) = unifyAll l g
- in case unify s t g1 of
- Ok g2 -> (g2, c)
- _ -> (g1, a : c)
-
-unify :: Term -> Term -> Unifier -> Err Unifier
-unify e1 e2 g =
- case (e1, e2) of
- (Meta s, t) -> do
- tg <- subst_all g t
- let sg = maybe e1 id (lookup s g)
- if (sg == Meta s) then extend g s tg else unify sg tg g
- (t, Meta s) -> unify e2 e1 g
- (Q _ a, Q _ b) | (a == b) -> return g ---- qualif?
- (QC _ a, QC _ b) | (a == b) -> return g ----
- (Vr x, Vr y) | (x == y) -> return g
- (Abs _ x b, Abs _ y c) -> do let c' = substTerm [x] [(y,Vr x)] c
- unify b c' g
- (App c a, App d b) -> case unify c d g of
- Ok g1 -> unify a b g1
- _ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1))
- (RecType xs,RecType ys) | xs == ys -> return g
- _ -> Bad (render (text "fail unify" <+> ppTerm Unqualified 0 e1))
-
-extend :: Unifier -> MetaId -> Term -> Err Unifier
-extend g s t | (t == Meta s) = return g
- | occCheck s t = Bad (render (text "occurs check" <+> ppTerm Unqualified 0 t))
- | True = return ((s, t) : g)
-
-subst_all :: Unifier -> Term -> Err Term
-subst_all s u =
- case (s,u) of
- ([], t) -> return t
- (a : l, t) -> do
- t' <- (subst_all l t) --- successive substs - why ?
- return $ substMetas [a] t'
-
-substMetas :: [(MetaId,Term)] -> Term -> Term
-substMetas subst trm = case trm of
- Meta x -> case lookup x subst of
- Just t -> t
- _ -> trm
- _ -> composSafeOp (substMetas subst) trm
-
-occCheck :: MetaId -> Term -> Bool
-occCheck s u = case u of
- Meta v -> s == v
- App c a -> occCheck s c || occCheck s a
- Abs _ x b -> occCheck s b
- _ -> False
-
diff --git a/src/GF/Grammar/Values.hs b/src/GF/Grammar/Values.hs
deleted file mode 100644
index 1a68ddc89..000000000
--- a/src/GF/Grammar/Values.hs
+++ /dev/null
@@ -1,96 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Values
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > 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
- Exp, Val(..), Env,
- -- * annotated tree used in editing
---Z Tree, TrNode(..), Atom(..),
- Binds, Constraints, MetaSubst,
- -- * for TC
- valAbsInt, valAbsFloat, valAbsString, vType,
- isPredefCat,
- eType,
---Z tree2exp, loc2treeFocus
- ) where
-
-import GF.Data.Operations
----Z import GF.Data.Zipper
-
-import GF.Infra.Ident
-import GF.Grammar.Grammar
-import GF.Grammar.Predef
-
--- values used in TC type checking
-
-type Exp = Term
-
-data Val = VGen Int Ident | VApp Val Val | VCn QIdent | VRecType [(Label,Val)] | VType | VClos Env Exp
- deriving (Eq,Show)
-
-type Env = [(Ident,Val)]
-
-{-
--- annotated tree used in editing
-
-type Tree = Tr TrNode
-
-newtype TrNode = N (Binds,Atom,Val,(Constraints,MetaSubst),Bool)
- deriving (Eq,Show)
-
-data Atom =
- AtC Fun | AtM MetaId | AtV Ident | AtL String | AtI Integer | AtF Double
- deriving (Eq,Show)
--}
-type Binds = [(Ident,Val)]
-type Constraints = [(Val,Val)]
-type MetaSubst = [(MetaId,Val)]
-
-
--- for TC
-
-valAbsInt :: Val
-valAbsInt = VCn (cPredefAbs, cInt)
-
-valAbsFloat :: Val
-valAbsFloat = VCn (cPredefAbs, cFloat)
-
-valAbsString :: Val
-valAbsString = VCn (cPredefAbs, cString)
-
-vType :: Val
-vType = VType
-
-eType :: Exp
-eType = Sort cType
-
-{-
-tree2exp :: Tree -> Exp
-tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where
- at' = case at of
- AtC (m,c) -> Q m c
- AtV i -> Vr i
- AtM m -> Meta m
- AtL s -> K s
- AtI s -> EInt s
- AtF s -> EFloat s
- bi' = map fst bi
- ts' = map tree2exp ts
-
-loc2treeFocus :: Loc TrNode -> Tree
-loc2treeFocus (Loc (Tr (a,ts),p)) =
- loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p))
- where
- (mark, nomark) = (\(N (a,b,c,d,_)) -> N(a,b,c,d,True),
- \(N (a,b,c,d,_)) -> N(a,b,c,d,False))
--}
generated by cgit v1.2.3 (git 2.39.1) at 2026-06-11 20:34:41 +0000