GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-16 14:42:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

the compiler now compiles with the new runtime

Browse Source
This commit is contained in:
krangelov
2021-09-13 18:32:57 +02:00
parent c5ce2fd4b7
commit cf7673525f
26 changed files with 765 additions and 105 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
src/compiler/GF/Command/Commands.hs
View File

@@ -6,7 +6,6 @@ module GF.Command.Commands (
import Prelude hiding (putStrLn,(<>))
import PGF2
import PGF2.Internal(writePGF)
import GF.Compile.Export
import GF.Compile.ToAPI
@@ -666,7 +665,7 @@ pgfCommands = Map.fromList [
[e] -> case unApp e of
Just (id, []) -> case functionType pgf id of
Just ty -> do putStrLn (showFun pgf id ty)
putStrLn ("Probability: "++show (treeProbability pgf e))
putStrLn ("Probability: "++show (exprProbability pgf e))
return void
Nothing -> case categoryContext pgf id of
Just hypos -> do putStrLn ("cat "++id++if null hypos then "" else ' ':showContext [] hypos)
@@ -682,7 +681,7 @@ pgfCommands = Map.fromList [
Left err -> error err
Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e)
putStrLn ("Type: "++showType [] ty)
putStrLn ("Probability: "++show (treeProbability pgf e))
putStrLn ("Probability: "++show (exprProbability pgf e))
return void
_ -> do putStrLn "a single identifier or expression is expected from the command"
return void,
@@ -800,8 +799,8 @@ pgfCommands = Map.fromList [
showFun pgf id ty = kwd++" "++ id ++ " : " ++ showType [] ty
where
kwd | functionIsDataCon pgf id = "data"
| otherwise = "fun"
kwd | functionIsConstructor pgf id = "data"
| otherwise = "fun"
morphos pgf opts s =
[(s,lookupMorpho concr s) | concr <- optLangs pgf opts]

3
src/compiler/GF/Compile/CFGtoPGF.hs
View File

@@ -21,7 +21,7 @@ import Data.Maybe(fromMaybe)
--------------------------
cf2pgf :: Options -> FilePath -> ParamCFG -> Map.Map Fun Double -> PGF
cf2pgf opts fpath cf probs =
cf2pgf opts fpath cf probs = error "TODO: cf2pgf" {-
build (let abstr = cf2abstr cf probs
in newPGF [] aname abstr [(cname, cf2concr opts abstr cf)])
where
@@ -134,3 +134,4 @@ mkRuleName rule =
case ruleName rule of
CFObj n _ -> n
_ -> "_"
-}

24
src/compiler/GF/Compile/Compute/Predef.hs
View File

@@ -4,7 +4,7 @@ module GF.Compile.Compute.Predef(predef,predefName,delta) where
import qualified Data.Map as Map
import Data.Array(array,(!))
import Data.List (isInfixOf)
import Data.List (isInfixOf,genericTake,genericDrop,genericLength)
import Data.Char (isUpper,toLower,toUpper)
import Control.Monad(ap)
@@ -20,7 +20,7 @@ class Predef a where
toValue :: a -> Value
fromValue :: Value -> Err a
instance Predef Int where
instance Predef Integer where
toValue = VInt
fromValue (VInt i) = return i
fromValue v = verror "Int" v
@@ -87,8 +87,8 @@ predefList =
delta f vs =
case f of
Drop -> fromNonExist vs NonExist (ap2 (drop::Int->String->String))
Take -> fromNonExist vs NonExist (ap2 (take::Int->String->String))
Drop -> fromNonExist vs NonExist (ap2 (genericDrop::Integer->String->String))
Take -> fromNonExist vs NonExist (ap2 (genericTake::Integer->String->String))
Tk -> fromNonExist vs NonExist (ap2 tk)
Dp -> fromNonExist vs NonExist (ap2 dp)
EqStr -> fromNonExist vs PFalse (ap2 ((==)::String->String->Bool))
@@ -97,10 +97,10 @@ delta f vs =
ToUpper -> fromNonExist vs NonExist (ap1 (map toUpper))
ToLower -> fromNonExist vs NonExist (ap1 (map toLower))
IsUpper -> fromNonExist vs PFalse (ap1 (all' isUpper))
Length -> fromNonExist vs (0::Int) (ap1 (length::String->Int))
Plus -> ap2 ((+)::Int->Int->Int)
EqInt -> ap2 ((==)::Int->Int->Bool)
LessInt -> ap2 ((<)::Int->Int->Bool)
Length -> fromNonExist vs (0::Integer) (ap1 (genericLength::String->Integer))
Plus -> ap2 ((+)::Integer->Integer->Integer)
EqInt -> ap2 ((==)::Integer->Integer->Bool)
LessInt -> ap2 ((<)::Integer->Integer->Bool)
{- -- | Show | Read | ToStr | MapStr | EqVal -}
Error -> ap1 VError
Trace -> ap2 vtrace
@@ -139,8 +139,12 @@ delta f vs =
-- unimpl id = bug $ "unimplemented predefined function: "++showIdent id
-- problem id vs = bug $ "unexpected arguments: Predef."++showIdent id++" "++show vs
tk i s = take (max 0 (length s - i)) s :: String
dp i s = drop (max 0 (length s - i)) s :: String
tk :: Integer -> String -> String
tk i s = genericTake (max 0 (genericLength s - i)) s
dp :: Integer -> String -> String
dp i s = genericDrop (max 0 (genericLength s - i)) s
occur s t = isInfixOf (s::String) (t::String)
occurs s t = any (`elem` (t::String)) (s::String)
all' = all :: (a->Bool) -> [a] -> Bool

2
src/compiler/GF/Compile/Compute/Value.hs
View File

@@ -14,7 +14,7 @@ data Value
-- -- | VClosure Env Term -- used in Typecheck.ConcreteNew
| VAbs BindType Ident Binding -- used in Compute.Concrete
| VProd BindType Value Ident Binding -- used in Compute.Concrete
| VInt Int
| VInt Integer
| VFloat Double
| VString String
| VSort Ident

8
src/compiler/GF/Compile/ConcreteToHaskell.hs
View File

@@ -1,5 +1,7 @@
-- | Translate concrete syntax to Haskell
module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
import PGF2(Literal(..))
import Data.List(isPrefixOf,sort,sortOn)
import qualified Data.Map as M
import qualified Data.Set as S
@@ -181,9 +183,9 @@ concrete2haskell opts
ppL l =
case l of
FloatConstant x -> pure (lit x)
IntConstant n -> pure (lit n)
StrConstant s -> pure (token s)
LFlt x -> pure (lit x)
LInt n -> pure (lit n)
LStr s -> pure (token s)
pId p@(ParamId s) =
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack

3
src/compiler/GF/Compile/GenerateBC.hs
View File

@@ -4,7 +4,8 @@ module GF.Compile.GenerateBC(generateByteCode) where
import GF.Grammar
import GF.Grammar.Lookup(lookupAbsDef,lookupFunType)
import GF.Data.Operations
import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..),Literal(..))
import PGF2(Literal(..))
import PGF2.Internal(CodeLabel,Instr(..),IVal(..),TailInfo(..))
import qualified Data.Map as Map
import Data.List(nub,mapAccumL)
import Data.Maybe(fromMaybe)

20
src/compiler/GF/Compile/GrammarToCanonical.hs
View File

@@ -19,7 +19,7 @@ import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
import GF.Infra.Option(Options,optionsPGF)
import PGF2.Internal(Literal(..))
import PGF2(Literal(..))
import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
import GF.Grammar.Canonical as C
import System.FilePath ((</>), (<.>))
@@ -193,11 +193,11 @@ convert' gr vs = ppT
Cn x -> VarValue (gId x) -- hmm
Con c -> ParamConstant (Param (gId c) [])
Sort k -> VarValue (gId k)
EInt n -> LiteralValue (IntConstant n)
EInt n -> LiteralValue (LInt n)
Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
QC (m,n) -> ParamConstant (Param (gQId m n) [])
K s -> LiteralValue (StrConstant s)
Empty -> LiteralValue (StrConstant "")
K s -> LiteralValue (LStr s)
Empty -> LiteralValue (LStr "")
FV ts -> VariantValue (map ppT ts)
Alts t' vs -> alts vs (ppT t')
_ -> error $ "convert' ppT: " ++ show t
@@ -265,8 +265,8 @@ convert' gr vs = ppT
concatValue :: LinValue -> LinValue -> LinValue
concatValue v1 v2 =
case (v1,v2) of
(LiteralValue (StrConstant ""),_) -> v2
(_,LiteralValue (StrConstant "")) -> v1
(LiteralValue (LStr ""),_) -> v2
(_,LiteralValue (LStr "")) -> v1
_ -> ConcatValue v1 v2
-- | Smart constructor for projections
@@ -429,11 +429,5 @@ unqual n = Unqual (ident2raw n)
convFlags :: G.Grammar -> ModuleName -> Flags
convFlags gr mn =
Flags [(rawIdentS n,convLit v) |
Flags [(rawIdentS n,v) |
(n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
where
convLit l =
case l of
LStr s -> Str s
LInt i -> C.Int i
LFlt d -> Flt d

3
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -30,7 +30,7 @@ import GHC.Prim
import GHC.Base(getTag)
grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
grammar2PGF opts gr am probs = do
grammar2PGF opts gr am probs = error "TODO: grammar2PGF" {-do
cnc_infos <- getConcreteInfos gr am
return $
build (let gflags = if flag optSplitPGF opts
@@ -445,3 +445,4 @@ compareCaseInsensitive (x:xs) (y:ys) =
EQ -> compare x y
x -> x
x -> x
-}

3
src/compiler/GF/Compile/OptimizePGF.hs
View File

@@ -20,7 +20,7 @@ type ConcrData = ([(FId,[FunId])], -- ^ Lindefs
[(Cat,FId,FId,[String])]) -- ^ Concrete categories
optimizePGF :: Cat -> ConcrData -> ConcrData
optimizePGF startCat = topDownFilter startCat . bottomUpFilter
optimizePGF startCat = error "TODO: optimizePGF" {- topDownFilter startCat . bottomUpFilter
catString = "String"
catInt = "Int"
@@ -187,3 +187,4 @@ filterProductions prods0 hoc0 prods
accumHOC hoc (PApply funid args) = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc fid -> IntSet.insert fid hoc) hoc (map snd hypos)) hoc args
accumHOC hoc _ = hoc
-}

5
src/compiler/GF/Compile/PGFtoJSON.hs
View File

@@ -6,8 +6,8 @@ import Text.JSON
import qualified Data.Map as Map
pgf2json :: PGF -> String
pgf2json pgf =
encode $ makeObj
pgf2json pgf = error "TODO: pgf2json"
{- encode $ makeObj
[ ("abstract", abstract2json pgf)
, ("concretes", makeObj $ map concrete2json
(Map.toList (languages pgf)))
@@ -108,3 +108,4 @@ new f xs =
[ ("type", showJSON f)
, ("args", showJSON xs)
]
-}

2
src/compiler/GF/Compile/TypeCheck/TC.hs
View File

@@ -35,7 +35,7 @@ data AExp =
AVr Ident Val
| ACn QIdent Val
| AType
| AInt Int
| AInt Integer
| AFloat Double
| AStr String
| AMeta MetaId Val

2
src/compiler/GF/Compiler.hs
View File

@@ -1,7 +1,7 @@
module GF.Compiler (mainGFC, linkGrammars, writeGrammar, writeOutputs) where
import PGF2
import PGF2.Internal(unionPGF,writePGF,writeConcr)
import PGF2.Internal(unionPGF,writeConcr)
import GF.Compile as S(batchCompile,link,srcAbsName)
import GF.CompileInParallel as P(parallelBatchCompile)
import GF.Compile.Export

2
src/compiler/GF/Grammar/BNFC.hs
View File

@@ -25,7 +25,7 @@ data BNFCRule = BNFCRule {
ruleName :: CFTerm }
| BNFCCoercions {
coerCat :: Cat,
coerNum :: Int }
coerNum :: Integer }
| BNFCTerminator {
termNonEmpty :: Bool,
termCat :: Cat,

3
src/compiler/GF/Grammar/Binary.hs
View File

@@ -22,7 +22,8 @@ import GF.Infra.Option
import GF.Infra.UseIO(MonadIO(..))
import GF.Grammar.Grammar
import PGF2.Internal(Literal(..),Symbol(..))
import PGF2(Literal(..))
import PGF2.Internal(Symbol(..))
-- Please change this every time when the GFO format is changed
gfoVersion = "GF04"

27
src/compiler/GF/Grammar/Canonical.hs
View File

@@ -9,9 +9,11 @@
{-# LANGUAGE DeriveTraversable #-}
module GF.Grammar.Canonical where
import Prelude hiding ((<>))
import GF.Text.Pretty
import GF.Infra.Ident (RawIdent)
import PGF(Literal(..))
-- | A Complete grammar
data Grammar = Grammar Abstract [Concrete] deriving Show
@@ -58,7 +60,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
-- | Linearization value, RHS of @lin@
data LinValue = ConcatValue LinValue LinValue
| LiteralValue LinLiteral
| LiteralValue Literal
| ErrorValue String
| ParamConstant ParamValue
| PredefValue PredefId
@@ -74,11 +76,6 @@ data LinValue = ConcatValue LinValue LinValue
| CommentedValue String LinValue
deriving (Eq,Ord,Show)
data LinLiteral = FloatConstant Float
| IntConstant Int
| StrConstant String
deriving (Eq,Ord,Show)
data LinPattern = ParamPattern ParamPattern
| RecordPattern [RecordRow LinPattern]
| TuplePattern [LinPattern]
@@ -120,9 +117,8 @@ newtype FunId = FunId Id deriving (Eq,Show)
data VarId = Anonymous | VarId Id deriving Show
newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
newtype Flags = Flags [(FlagName,Literal)] deriving Show
type FlagName = Id
data FlagValue = Str String | Int Int | Flt Double deriving Show
-- *** Identifiers
@@ -243,13 +239,13 @@ instance PPA LinValue where
VarValue v -> pp v
_ -> parens lv
instance Pretty LinLiteral where pp = ppA
instance Pretty Literal where pp = ppA
instance PPA LinLiteral where
instance PPA Literal where
ppA l = case l of
FloatConstant f -> pp f
IntConstant n -> pp n
StrConstant s -> doubleQuotes s -- hmm
LFlt f -> pp f
LInt n -> pp n
LStr s -> doubleQuotes s -- hmm
instance RhsSeparator LinValue where rhsSep _ = pp "="
@@ -298,11 +294,6 @@ instance Pretty Flags where
where
ppFlag (name,value) = name <+> "=" <+> value <>";"
instance Pretty FlagValue where
pp (Str s) = pp s
pp (Int i) = pp i
pp (Flt d) = pp d
--------------------------------------------------------------------------------
-- | Pretty print atomically (i.e. wrap it in parentheses if necessary)
class Pretty a => PPA a where ppA :: a -> Doc

21
src/compiler/GF/Grammar/CanonicalJSON.hs
View File

@@ -8,7 +8,7 @@ import Data.Ratio (denominator, numerator)
import GF.Grammar.Canonical
import Control.Monad (guard)
import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
import PGF(Literal(..))
encodeJSON :: FilePath -> Grammar -> IO ()
encodeJSON fpath g = writeFile fpath (encode g)
@@ -171,13 +171,13 @@ instance JSON LinValue where
<|> do vs <- readJSON o :: Result [LinValue]
return (foldr1 ConcatValue vs)
instance JSON LinLiteral where
instance JSON Literal where
-- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
showJSON (StrConstant s) = showJSON s
showJSON (FloatConstant f) = showJSON f
showJSON (IntConstant n) = showJSON n
showJSON (LStr s) = showJSON s
showJSON (LFlt f) = showJSON f
showJSON (LInt n) = showJSON n
readJSON = readBasicJSON StrConstant IntConstant FloatConstant
readJSON = readBasicJSON LStr LInt LFlt
instance JSON LinPattern where
-- wildcards and patterns without arguments are encoded as strings:
@@ -262,15 +262,6 @@ instance JSON Flags where
where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
return (rawIdentS lbl, value)
instance JSON FlagValue where
-- flag values are encoded as basic JSON types:
showJSON (Str s) = showJSON s
showJSON (Int i) = showJSON i
showJSON (Flt f) = showJSON f
readJSON = readBasicJSON Str Int Flt
--------------------------------------------------------------------------------
-- ** Convenience functions

4
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -354,7 +354,7 @@ data Term =
| Cn Ident -- ^ constant
| Con Ident -- ^ constructor
| Sort Ident -- ^ basic type
| EInt Int -- ^ integer literal
| EInt Integer -- ^ integer literal
| EFloat Double -- ^ floating point literal
| K String -- ^ string literal or token: @\"foo\"@
| Empty -- ^ the empty string @[]@
@@ -409,7 +409,7 @@ data Patt =
| PW -- ^ wild card pattern: @_@
| PR [(Label,Patt)] -- ^ record pattern: @{r = p ; ...}@ -- only concrete
| PString String -- ^ string literal pattern: @\"foo\"@ -- only abstract
| PInt Int -- ^ integer literal pattern: @12@ -- 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

2
src/compiler/GF/Grammar/Lexer.x
View File

@@ -130,7 +130,7 @@ data Token
| T_separator
| T_nonempty
| T_String String -- string literals
| T_Integer Int -- integer literals
| T_Integer Integer -- integer literals
| T_Double Double -- double precision float literals
| T_Ident Ident
| T_EOF

6
src/compiler/GF/Grammar/Macros.hs
View File

@@ -216,7 +216,7 @@ typeTok = Sort cTok
typeStrs = Sort cStrs
typeString, typeFloat, typeInt :: Type
typeInts :: Int -> Type
typeInts :: Integer -> Type
typePBool :: Type
typeError :: Type
@@ -227,7 +227,7 @@ typeInts i = App (cnPredef cInts) (EInt i)
typePBool = cnPredef cPBool
typeError = cnPredef cErrorType
isTypeInts :: Type -> Maybe Int
isTypeInts :: Type -> Maybe Integer
isTypeInts (App c (EInt i)) | c == cnPredef cInts = Just i
isTypeInts _ = Nothing
@@ -324,7 +324,7 @@ freshAsTerm s = Vr (varX (readIntArg s))
string2term :: String -> Term
string2term = K
int2term :: Int -> Term
int2term :: Integer -> Term
int2term = EInt
float2term :: Double -> Term

2
src/compiler/GF/Infra/Option.hs
View File

@@ -35,7 +35,7 @@ import GF.Infra.Ident
import GF.Infra.GetOpt
import GF.Grammar.Predef
import System.FilePath
import PGF2.Internal(Literal(..))
import PGF2(Literal(..))
import GF.Data.Operations(Err,ErrorMonad(..),liftErr)

3
src/compiler/GF/Speech/PGFToCFG.hs
View File

@@ -25,7 +25,7 @@ toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc
type Profile = [Int]
pgfToCFG :: PGF -> Concr -> CFG
pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule rules)
pgfToCFG pgf cnc = error "TODO: pgfToCFG" {- mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule rules)
where
(_,start_cat,_) = unType (startCat pgf)
@@ -116,3 +116,4 @@ pgfToCFG pgf cnc = mkCFG start_cat extCats (startRules ++ concatMap ruleToCFRule
ruleToCFRule (c,PCoerce c') =
[Rule (fcatToCat c l) [NonTerminal (fcatToCat c' l)] (CFRes 0)
| l <- [0..catLinArity c-1]]
-}