diff options
| author | krasimir <krasimir@chalmers.se> | 2009-12-13 18:50:29 +0000 |
|---|---|---|
| committer | krasimir <krasimir@chalmers.se> | 2009-12-13 18:50:29 +0000 |
| commit | f85232947e74ee7ef8c7b0ad2338212e7e68f1be (patch) | |
| tree | 667b886a5e3a4b026a63d4e3597f32497d824761 /src/compiler/GF/Grammar | |
| parent | d88a865faff59c98fc91556ff8700b10ee5f2df8 (diff) | |
reorganize the directories under src, and rescue the JavaScript interpreter from deprecated
Diffstat (limited to 'src/compiler/GF/Grammar')
| -rw-r--r-- | src/compiler/GF/Grammar/Binary.hs | 261 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/CF.hs | 128 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Grammar.hs | 230 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Lexer.hs | 478 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Lexer.x | 272 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Lockfield.hs | 52 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Lookup.hs | 188 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/MMacros.hs | 279 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Macros.hs | 627 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Parser.y | 739 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/PatternMatch.hs | 165 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Predef.hs | 180 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Printer.hs | 317 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Unify.hs | 97 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Values.hs | 96 |
15 files changed, 4109 insertions, 0 deletions
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs new file mode 100644 index 000000000..fbad5ac7e --- /dev/null +++ b/src/compiler/GF/Grammar/Binary.hs @@ -0,0 +1,261 @@ +----------------------------------------------------------------------
+-- |
+-- 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/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs new file mode 100644 index 000000000..a1d716994 --- /dev/null +++ b/src/compiler/GF/Grammar/CF.hs @@ -0,0 +1,128 @@ +---------------------------------------------------------------------- +-- | +-- 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/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs new file mode 100644 index 000000000..8d1468d9d --- /dev/null +++ b/src/compiler/GF/Grammar/Grammar.hs @@ -0,0 +1,230 @@ +---------------------------------------------------------------------- +-- | +-- 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/compiler/GF/Grammar/Lexer.hs b/src/compiler/GF/Grammar/Lexer.hs new file mode 100644 index 000000000..7cacb0588 --- /dev/null +++ b/src/compiler/GF/Grammar/Lexer.hs @@ -0,0 +1,478 @@ +{-# 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/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x new file mode 100644 index 000000000..d6f49bbb1 --- /dev/null +++ b/src/compiler/GF/Grammar/Lexer.x @@ -0,0 +1,272 @@ +-- -*- 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/compiler/GF/Grammar/Lockfield.hs b/src/compiler/GF/Grammar/Lockfield.hs new file mode 100644 index 000000000..3e78a48b6 --- /dev/null +++ b/src/compiler/GF/Grammar/Lockfield.hs @@ -0,0 +1,52 @@ +---------------------------------------------------------------------- +-- | +-- 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/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs new file mode 100644 index 000000000..074f0c5ec --- /dev/null +++ b/src/compiler/GF/Grammar/Lookup.hs @@ -0,0 +1,188 @@ +{-# 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/compiler/GF/Grammar/MMacros.hs b/src/compiler/GF/Grammar/MMacros.hs new file mode 100644 index 000000000..a7f746b66 --- /dev/null +++ b/src/compiler/GF/Grammar/MMacros.hs @@ -0,0 +1,279 @@ +---------------------------------------------------------------------- +-- | +-- 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/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs new file mode 100644 index 000000000..799cd9ec5 --- /dev/null +++ b/src/compiler/GF/Grammar/Macros.hs @@ -0,0 +1,627 @@ +---------------------------------------------------------------------- +-- | +-- 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/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y new file mode 100644 index 000000000..320053674 --- /dev/null +++ b/src/compiler/GF/Grammar/Parser.y @@ -0,0 +1,739 @@ +{ +{-# 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/compiler/GF/Grammar/PatternMatch.hs b/src/compiler/GF/Grammar/PatternMatch.hs new file mode 100644 index 000000000..b8f7eff7d --- /dev/null +++ b/src/compiler/GF/Grammar/PatternMatch.hs @@ -0,0 +1,165 @@ +---------------------------------------------------------------------- +-- | +-- 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/compiler/GF/Grammar/Predef.hs b/src/compiler/GF/Grammar/Predef.hs new file mode 100644 index 000000000..045df06ca --- /dev/null +++ b/src/compiler/GF/Grammar/Predef.hs @@ -0,0 +1,180 @@ +---------------------------------------------------------------------- +-- | +-- 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/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs new file mode 100644 index 000000000..06cac9705 --- /dev/null +++ b/src/compiler/GF/Grammar/Printer.hs @@ -0,0 +1,317 @@ +----------------------------------------------------------------------
+-- |
+-- 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/compiler/GF/Grammar/Unify.hs b/src/compiler/GF/Grammar/Unify.hs new file mode 100644 index 000000000..9bb49cfe2 --- /dev/null +++ b/src/compiler/GF/Grammar/Unify.hs @@ -0,0 +1,97 @@ +---------------------------------------------------------------------- +-- | +-- 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/compiler/GF/Grammar/Values.hs b/src/compiler/GF/Grammar/Values.hs new file mode 100644 index 000000000..1a68ddc89 --- /dev/null +++ b/src/compiler/GF/Grammar/Values.hs @@ -0,0 +1,96 @@ +---------------------------------------------------------------------- +-- | +-- 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)) +-} |