forked from GitHub/gf-core
reorganize the directories under src, and rescue the JavaScript interpreter from deprecated
This commit is contained in:
krasimir
261
src/compiler/GF/Grammar/Binary.hs
Normal file
261
src/compiler/GF/Grammar/Binary.hs
Normal file
@@ -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"
|
||||
128
src/compiler/GF/Grammar/CF.hs
Normal file
128
src/compiler/GF/Grammar/CF.hs
Normal file
@@ -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
|
||||
|
||||
230
src/compiler/GF/Grammar/Grammar.hs
Normal file
230
src/compiler/GF/Grammar/Grammar.hs
Normal file
@@ -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))
|
||||
478
src/compiler/GF/Grammar/Lexer.hs
Normal file
478
src/compiler/GF/Grammar/Lexer.hs
Normal file
File diff suppressed because one or more lines are too long
272
src/compiler/GF/Grammar/Lexer.x
Normal file
272
src/compiler/GF/Grammar/Lexer.x
Normal file
@@ -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
|
||||
|
||||
}
|
||||
52
src/compiler/GF/Grammar/Lockfield.hs
Normal file
52
src/compiler/GF/Grammar/Lockfield.hs
Normal file
@@ -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_"
|
||||
188
src/compiler/GF/Grammar/Lookup.hs
Normal file
188
src/compiler/GF/Grammar/Lookup.hs
Normal file
@@ -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))
|
||||
279
src/compiler/GF/Grammar/MMacros.hs
Normal file
279
src/compiler/GF/Grammar/MMacros.hs
Normal file
@@ -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)
|
||||
-}
|
||||
627
src/compiler/GF/Grammar/Macros.hs
Normal file
627
src/compiler/GF/Grammar/Macros.hs
Normal file
@@ -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)]])
|
||||
739
src/compiler/GF/Grammar/Parser.y
Normal file
739
src/compiler/GF/Grammar/Parser.y
Normal file
@@ -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"
|
||||
|
||||
}
|
||||
|
||||
165
src/compiler/GF/Grammar/PatternMatch.hs
Normal file
165
src/compiler/GF/Grammar/PatternMatch.hs
Normal file
@@ -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
|
||||
|
||||
180
src/compiler/GF/Grammar/Predef.hs
Normal file
180
src/compiler/GF/Grammar/Predef.hs
Normal file
@@ -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")
|
||||
317
src/compiler/GF/Grammar/Printer.hs
Normal file
317
src/compiler/GF/Grammar/Printer.hs
Normal file
@@ -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
|
||||
97
src/compiler/GF/Grammar/Unify.hs
Normal file
97
src/compiler/GF/Grammar/Unify.hs
Normal file
@@ -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
|
||||
|
||||
96
src/compiler/GF/Grammar/Values.hs
Normal file
96
src/compiler/GF/Grammar/Values.hs
Normal file
@@ -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))
|
||||
-}
|
||||
Reference in New Issue
Block a user