{-# LANGUAGE BangPatterns, FlexibleContexts #-}
module GF.Compile.GrammarToPGF (mkCanon2pgf) where
import GF.Compile.GeneratePMCFG
import GF.Compile.GenerateBC
import PGF(CId,mkCId,utf8CId)
import PGF.Internal(fidInt,fidFloat,fidString,fidVar)
import PGF.Internal(updateProductionIndices)
import qualified PGF.Internal as C
import qualified PGF.Internal as D
import GF.Grammar.Predef
import GF.Grammar.Grammar
import qualified GF.Grammar.Lookup as Look
import qualified GF.Grammar as A
import qualified GF.Grammar.Macros as GM
import GF.Infra.Ident
import GF.Infra.Option
import GF.Infra.UseIO (IOE)
import GF.Data.Operations
import Data.List
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Array.IArray
mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE D.PGF
mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE PGF
mkCanon2pgf Options
opts SourceGrammar
gr ModuleName
am = do
(CId
an,Abstr
abs) <- ModuleName -> IO (CId, Abstr)
forall (m :: * -> *). Monad m => ModuleName -> m (CId, Abstr)
mkAbstr ModuleName
am
[(CId, Concr)]
cncs <- (ModuleName -> IO (CId, Concr))
-> [ModuleName] -> IO [(CId, Concr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModuleName -> IO (CId, Concr)
forall (m :: * -> *).
(MonadFail m, Output m) =>
ModuleName -> m (CId, Concr)
mkConcr (SourceGrammar -> ModuleName -> [ModuleName]
allConcretes SourceGrammar
gr ModuleName
am)
PGF -> IOE PGF
forall (m :: * -> *) a. Monad m => a -> m a
return (PGF -> IOE PGF) -> PGF -> IOE PGF
forall a b. (a -> b) -> a -> b
$ PGF -> PGF
updateProductionIndices (Map CId Literal -> CId -> Abstr -> Map CId Concr -> PGF
D.PGF Map CId Literal
forall k a. Map k a
Map.empty CId
an Abstr
abs ([(CId, Concr)] -> Map CId Concr
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(CId, Concr)]
cncs))
where
cenv :: GlobalEnv
cenv = Options -> SourceGrammar -> GlobalEnv
resourceValues Options
opts SourceGrammar
gr
mkAbstr :: ModuleName -> m (CId, Abstr)
mkAbstr ModuleName
am = (CId, Abstr) -> m (CId, Abstr)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName -> CId
mi2i ModuleName
am, Map CId Literal
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
-> Map CId ([Hypo], [(Double, CId)], Double)
-> Abstr
D.Abstr Map CId Literal
flags Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs Map CId ([Hypo], [(Double, CId)], Double)
cats)
where
aflags :: Options
aflags = (String -> Options)
-> (ModuleInfo -> Options) -> Err ModuleInfo -> Options
forall b a. (String -> b) -> (a -> b) -> Err a -> b
err (Options -> String -> Options
forall a b. a -> b -> a
const Options
noOptions) ModuleInfo -> Options
mflags (SourceGrammar -> ModuleName -> Err ModuleInfo
forall (m :: * -> *).
ErrorMonad m =>
SourceGrammar -> ModuleName -> m ModuleInfo
lookupModule SourceGrammar
gr ModuleName
am)
adefs :: [((ModuleName, Ident), Info)]
adefs =
[((ModuleName
cPredefAbs,Ident
c), Maybe (L Context) -> Info
AbsCat (L Context -> Maybe (L Context)
forall a. a -> Maybe a
Just (Location -> Context -> L Context
forall a. Location -> a -> L a
L Location
NoLoc []))) | Ident
c <- [Ident
cFloat,Ident
cInt,Ident
cString]] [((ModuleName, Ident), Info)]
-> [((ModuleName, Ident), Info)] -> [((ModuleName, Ident), Info)]
forall a. [a] -> [a] -> [a]
++
SourceGrammar -> ModuleName -> [((ModuleName, Ident), Info)]
Look.allOrigInfos SourceGrammar
gr ModuleName
am
flags :: Map CId Literal
flags = [(CId, Literal)] -> Map CId Literal
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String -> CId
mkCId String
f,Literal
x) | (String
f,Literal
x) <- Options -> [(String, Literal)]
optionsPGF Options
aflags]
funs :: Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
funs = [(CId, (Type, Int, Maybe ([Equation], [[Instr]]), Double))]
-> Map CId (Type, Int, Maybe ([Equation], [[Instr]]), Double)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Ident -> CId
i2i Ident
f, ([Ident] -> Type -> Type
mkType [] Type
ty, Int
arity, SourceGrammar
-> Int -> Maybe [L ([Patt], Type)] -> Maybe ([Equation], [[Instr]])
mkDef SourceGrammar
gr Int
arity Maybe [L ([Patt], Type)]
mdef, Double
0)) |
((ModuleName
m,Ident
f),AbsFun (Just (L Location
_ Type
ty)) Maybe Int
ma Maybe [L ([Patt], Type)]
mdef Maybe Bool
_) <- [((ModuleName, Ident), Info)]
adefs,
let arity :: Int
arity = Maybe Int -> Maybe [L ([Patt], Type)] -> Type -> Int
forall a. Maybe Int -> Maybe a -> Type -> Int
mkArity Maybe Int
ma Maybe [L ([Patt], Type)]
mdef Type
ty]
cats :: Map CId ([Hypo], [(Double, CId)], Double)
cats = [(CId, ([Hypo], [(Double, CId)], Double))]
-> Map CId ([Hypo], [(Double, CId)], Double)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Ident -> CId
i2i Ident
c, (([Ident], [Hypo]) -> [Hypo]
forall a b. (a, b) -> b
snd ([Ident] -> Context -> ([Ident], [Hypo])
mkContext [] Context
cont),Ident -> [(Double, CId)]
forall a. Num a => Ident -> [(a, CId)]
catfuns Ident
c, Double
0)) |
((ModuleName
m,Ident
c),AbsCat (Just (L Location
_ Context
cont))) <- [((ModuleName, Ident), Info)]
adefs]
catfuns :: Ident -> [(a, CId)]
catfuns Ident
cat =
[(a
0,Ident -> CId
i2i Ident
f) | ((ModuleName
m,Ident
f),AbsFun (Just (L Location
_ Type
ty)) Maybe Int
_ Maybe [L ([Patt], Type)]
_ (Just Bool
True)) <- [((ModuleName, Ident), Info)]
adefs, (ModuleName, Ident) -> Ident
forall a b. (a, b) -> b
snd (Type -> (ModuleName, Ident)
GM.valCat Type
ty) Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cat]
mkConcr :: ModuleName -> m (CId, Concr)
mkConcr ModuleName
cm = do
let cflags :: Options
cflags = (String -> Options)
-> (ModuleInfo -> Options) -> Err ModuleInfo -> Options
forall b a. (String -> b) -> (a -> b) -> Err a -> b
err (Options -> String -> Options
forall a b. a -> b -> a
const Options
noOptions) ModuleInfo -> Options
mflags (SourceGrammar -> ModuleName -> Err ModuleInfo
forall (m :: * -> *).
ErrorMonad m =>
SourceGrammar -> ModuleName -> m ModuleInfo
lookupModule SourceGrammar
gr ModuleName
cm)
ciCmp :: Array Int Symbol -> Array Int Symbol -> Ordering
ciCmp | (Flags -> Bool) -> Options -> Bool
forall a. (Flags -> a) -> Options -> a
flag Flags -> Bool
optCaseSensitive Options
cflags = Array Int Symbol -> Array Int Symbol -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
| Bool
otherwise = Array Int Symbol -> Array Int Symbol -> Ordering
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) i1 i2.
(IArray a1 Symbol, IArray a2 Symbol, Ix i1, Ix i2) =>
a1 i1 Symbol -> a2 i2 Symbol -> Ordering
C.compareCaseInsensitve
(Map (Array Int Symbol) Int
ex_seqs,[((ModuleName, Ident), Info)]
cdefs) <- Map (Array Int Symbol) Int
-> [((ModuleName, Ident), Info)]
-> m (Map (Array Int Symbol) Int, [((ModuleName, Ident), Info)])
forall (m :: * -> *) a.
(MonadFail m, Output m) =>
Map (Array Int Symbol) Int
-> [((a, Ident), Info)]
-> m (Map (Array Int Symbol) Int, [((a, Ident), Info)])
addMissingPMCFGs
Map (Array Int Symbol) Int
forall k a. Map k a
Map.empty
([((ModuleName
cPredefAbs,Ident
c), Maybe (L Type)
-> Maybe (L Type)
-> Maybe (L Type)
-> Maybe (L Type)
-> Maybe PMCFG
-> Info
CncCat (L Type -> Maybe (L Type)
forall a. a -> Maybe a
Just (Location -> Type -> L Type
forall a. Location -> a -> L a
L Location
NoLoc Type
GM.defLinType)) Maybe (L Type)
forall a. Maybe a
Nothing Maybe (L Type)
forall a. Maybe a
Nothing Maybe (L Type)
forall a. Maybe a
Nothing Maybe PMCFG
forall a. Maybe a
Nothing) | Ident
c <- [Ident
cInt,Ident
cFloat,Ident
cString]] [((ModuleName, Ident), Info)]
-> [((ModuleName, Ident), Info)] -> [((ModuleName, Ident), Info)]
forall a. [a] -> [a] -> [a]
++
SourceGrammar -> ModuleName -> [((ModuleName, Ident), Info)]
Look.allOrigInfos SourceGrammar
gr ModuleName
cm)
let flags :: Map CId Literal
flags = [(CId, Literal)] -> Map CId Literal
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String -> CId
mkCId String
f,Literal
x) | (String
f,Literal
x) <- Options -> [(String, Literal)]
optionsPGF Options
cflags]
seqs :: Array Int (Array Int Symbol)
seqs = ([Array Int Symbol] -> Array Int (Array Int Symbol)
forall (a :: * -> * -> *) e. IArray a e => [e] -> a Int e
mkArray ([Array Int Symbol] -> Array Int (Array Int Symbol))
-> ([[Array Int Symbol]] -> [Array Int Symbol])
-> [[Array Int Symbol]]
-> Array Int (Array Int Symbol)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Array Int Symbol -> Array Int Symbol -> Ordering)
-> [Array Int Symbol] -> [Array Int Symbol]
forall a. (a -> a -> Ordering) -> [a] -> [a]
C.sortNubBy Array Int Symbol -> Array Int Symbol -> Ordering
ciCmp ([Array Int Symbol] -> [Array Int Symbol])
-> ([[Array Int Symbol]] -> [Array Int Symbol])
-> [[Array Int Symbol]]
-> [Array Int Symbol]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Array Int Symbol]] -> [Array Int Symbol]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) ([[Array Int Symbol]] -> Array Int (Array Int Symbol))
-> [[Array Int Symbol]] -> Array Int (Array Int Symbol)
forall a b. (a -> b) -> a -> b
$
(Map (Array Int Symbol) Int -> [Array Int Symbol]
forall k a. Map k a -> [k]
Map.keys Map (Array Int Symbol) Int
ex_seqs [Array Int Symbol] -> [[Array Int Symbol]] -> [[Array Int Symbol]]
forall a. a -> [a] -> [a]
: [[Array Int Symbol]
-> (Array Int (Array Int Symbol) -> [Array Int Symbol])
-> Maybe (Array Int (Array Int Symbol))
-> [Array Int Symbol]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Array Int (Array Int Symbol) -> [Array Int Symbol]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems (ModuleInfo -> Maybe (Array Int (Array Int Symbol))
mseqs ModuleInfo
mi) | (ModuleName
m,ModuleInfo
mi) <- SourceGrammar -> ModuleName -> [(ModuleName, ModuleInfo)]
allExtends SourceGrammar
gr ModuleName
cm])
ex_seqs_arr :: Array Int (Array Int Symbol)
ex_seqs_arr = Map (Array Int Symbol) Int -> Array Int (Array Int Symbol)
forall (a :: * -> * -> *) e. IArray a e => Map e Int -> a Int e
mkMapArray Map (Array Int Symbol) Int
ex_seqs :: Array SeqId Sequence
!(!Int
fid_cnt1,!Map CId CncCat
cnccats) = SourceGrammar
-> ModuleName
-> ModuleName
-> [((ModuleName, Ident), Info)]
-> (Int, Map CId CncCat)
forall p p a.
SourceGrammar
-> p -> p -> [((a, Ident), Info)] -> (Int, Map CId CncCat)
genCncCats SourceGrammar
gr ModuleName
am ModuleName
cm [((ModuleName, Ident), Info)]
cdefs
!(!Int
fid_cnt2,!IntMap (Set Production)
productions,!IntMap [Int]
lindefs,!IntMap [Int]
linrefs,!Array Int CncFun
cncfuns)
= SourceGrammar
-> ModuleName
-> ModuleName
-> Array Int (Array Int Symbol)
-> (Array Int Symbol -> Array Int Symbol -> Ordering)
-> Array Int (Array Int Symbol)
-> [((ModuleName, Ident), Info)]
-> Int
-> Map CId CncCat
-> (Int, IntMap (Set Production), IntMap [Int], IntMap [Int],
Array Int CncFun)
genCncFuns SourceGrammar
gr ModuleName
am ModuleName
cm Array Int (Array Int Symbol)
ex_seqs_arr Array Int Symbol -> Array Int Symbol -> Ordering
ciCmp Array Int (Array Int Symbol)
seqs [((ModuleName, Ident), Info)]
cdefs Int
fid_cnt1 Map CId CncCat
cnccats
printnames :: Map CId String
printnames = [((ModuleName, Ident), Info)] -> Map CId String
forall a. [((a, Ident), Info)] -> Map CId String
genPrintNames [((ModuleName, Ident), Info)]
cdefs
(CId, Concr) -> m (CId, Concr)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName -> CId
mi2i ModuleName
cm, Map CId Literal
-> Map CId String
-> Array Int CncFun
-> IntMap [Int]
-> IntMap [Int]
-> Array Int (Array Int Symbol)
-> IntMap (Set Production)
-> IntMap (Set Production)
-> Map CId (IntMap (Set Production))
-> Map CId CncCat
-> IntMap (IntMap (TrieMap String IntSet))
-> Int
-> Concr
D.Concr Map CId Literal
flags
Map CId String
printnames
Array Int CncFun
cncfuns
IntMap [Int]
lindefs
IntMap [Int]
linrefs
Array Int (Array Int Symbol)
seqs
IntMap (Set Production)
productions
IntMap (Set Production)
forall a. IntMap a
IntMap.empty
Map CId (IntMap (Set Production))
forall k a. Map k a
Map.empty
Map CId CncCat
cnccats
IntMap (IntMap (TrieMap String IntSet))
forall a. IntMap a
IntMap.empty
Int
fid_cnt2)
where
addMissingPMCFGs :: Map (Array Int Symbol) Int
-> [((a, Ident), Info)]
-> m (Map (Array Int Symbol) Int, [((a, Ident), Info)])
addMissingPMCFGs Map (Array Int Symbol) Int
seqs [] = (Map (Array Int Symbol) Int, [((a, Ident), Info)])
-> m (Map (Array Int Symbol) Int, [((a, Ident), Info)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Map (Array Int Symbol) Int
seqs,[])
addMissingPMCFGs Map (Array Int Symbol) Int
seqs (((a
m,Ident
id), Info
info):[((a, Ident), Info)]
is) = do
(Map (Array Int Symbol) Int
seqs,Info
info) <- Options
-> SourceGrammar
-> GlobalEnv
-> Maybe String
-> ModuleName
-> ModuleName
-> Map (Array Int Symbol) Int
-> Ident
-> Info
-> m (Map (Array Int Symbol) Int, Info)
forall (m :: * -> *) p.
(MonadFail m, Output m) =>
Options
-> SourceGrammar
-> GlobalEnv
-> Maybe String
-> ModuleName
-> p
-> Map (Array Int Symbol) Int
-> Ident
-> Info
-> m (Map (Array Int Symbol) Int, Info)
addPMCFG Options
opts SourceGrammar
gr GlobalEnv
cenv Maybe String
forall a. Maybe a
Nothing ModuleName
am ModuleName
cm Map (Array Int Symbol) Int
seqs Ident
id Info
info
(Map (Array Int Symbol) Int
seqs,[((a, Ident), Info)]
is ) <- Map (Array Int Symbol) Int
-> [((a, Ident), Info)]
-> m (Map (Array Int Symbol) Int, [((a, Ident), Info)])
addMissingPMCFGs Map (Array Int Symbol) Int
seqs [((a, Ident), Info)]
is
(Map (Array Int Symbol) Int, [((a, Ident), Info)])
-> m (Map (Array Int Symbol) Int, [((a, Ident), Info)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Map (Array Int Symbol) Int
seqs, ((a
m,Ident
id), Info
info) ((a, Ident), Info) -> [((a, Ident), Info)] -> [((a, Ident), Info)]
forall a. a -> [a] -> [a]
: [((a, Ident), Info)]
is)
i2i :: Ident -> CId
i2i :: Ident -> CId
i2i = ByteString -> CId
utf8CId (ByteString -> CId) -> (Ident -> ByteString) -> Ident -> CId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> ByteString
ident2utf8
mi2i :: ModuleName -> CId
mi2i :: ModuleName -> CId
mi2i (MN Ident
i) = Ident -> CId
i2i Ident
i
mkType :: [Ident] -> A.Type -> C.Type
mkType :: [Ident] -> Type -> Type
mkType [Ident]
scope Type
t =
case Type -> (Context, (ModuleName, Ident), [Type])
GM.typeForm Type
t of
(Context
hyps,(ModuleName
_,Ident
cat),[Type]
args) -> let ([Ident]
scope',[Hypo]
hyps') = [Ident] -> Context -> ([Ident], [Hypo])
mkContext [Ident]
scope Context
hyps
in [Hypo] -> CId -> [Expr] -> Type
C.DTyp [Hypo]
hyps' (Ident -> CId
i2i Ident
cat) ((Type -> Expr) -> [Type] -> [Expr]
forall a b. (a -> b) -> [a] -> [b]
map ([Ident] -> Type -> Expr
mkExp [Ident]
scope') [Type]
args)
mkExp :: [Ident] -> A.Term -> C.Expr
mkExp :: [Ident] -> Type -> Expr
mkExp [Ident]
scope Type
t =
case Type
t of
Q (ModuleName
_,Ident
c) -> CId -> Expr
C.EFun (Ident -> CId
i2i Ident
c)
QC (ModuleName
_,Ident
c) -> CId -> Expr
C.EFun (Ident -> CId
i2i Ident
c)
Vr Ident
x -> case Ident -> [(Ident, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Ident
x ([Ident] -> [Int] -> [(Ident, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Ident]
scope [Int
0..]) of
Just Int
i -> Int -> Expr
C.EVar Int
i
Maybe Int
Nothing -> Int -> Expr
C.EMeta Int
0
Abs BindType
b Ident
x Type
t-> BindType -> CId -> Expr -> Expr
C.EAbs BindType
b (Ident -> CId
i2i Ident
x) ([Ident] -> Type -> Expr
mkExp (Ident
xIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
scope) Type
t)
App Type
t1 Type
t2-> Expr -> Expr -> Expr
C.EApp ([Ident] -> Type -> Expr
mkExp [Ident]
scope Type
t1) ([Ident] -> Type -> Expr
mkExp [Ident]
scope Type
t2)
EInt Int
i -> Literal -> Expr
C.ELit (Int -> Literal
C.LInt (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i))
EFloat Double
f -> Literal -> Expr
C.ELit (Double -> Literal
C.LFlt Double
f)
K String
s -> Literal -> Expr
C.ELit (String -> Literal
C.LStr String
s)
Meta Int
i -> Int -> Expr
C.EMeta Int
i
Type
_ -> Int -> Expr
C.EMeta Int
0
mkPatt :: [Ident] -> Patt -> ([Ident], Patt)
mkPatt [Ident]
scope Patt
p =
case Patt
p of
A.PP (ModuleName
_,Ident
c) [Patt]
ps->let ([Ident]
scope',[Patt]
ps') = ([Ident] -> Patt -> ([Ident], Patt))
-> [Ident] -> [Patt] -> ([Ident], [Patt])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL [Ident] -> Patt -> ([Ident], Patt)
mkPatt [Ident]
scope [Patt]
ps
in ([Ident]
scope',CId -> [Patt] -> Patt
C.PApp (Ident -> CId
i2i Ident
c) [Patt]
ps')
A.PV Ident
x -> (Ident
xIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
scope,CId -> Patt
C.PVar (Ident -> CId
i2i Ident
x))
A.PAs Ident
x Patt
p -> let ([Ident]
scope',Patt
p') = [Ident] -> Patt -> ([Ident], Patt)
mkPatt [Ident]
scope Patt
p
in (Ident
xIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
scope',CId -> Patt -> Patt
C.PAs (Ident -> CId
i2i Ident
x) Patt
p')
Patt
A.PW -> ( [Ident]
scope,Patt
C.PWild)
A.PInt Int
i -> ( [Ident]
scope,Literal -> Patt
C.PLit (Int -> Literal
C.LInt (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)))
A.PFloat Double
f -> ( [Ident]
scope,Literal -> Patt
C.PLit (Double -> Literal
C.LFlt Double
f))
A.PString String
s -> ( [Ident]
scope,Literal -> Patt
C.PLit (String -> Literal
C.LStr String
s))
A.PImplArg Patt
p-> let ([Ident]
scope',Patt
p') = [Ident] -> Patt -> ([Ident], Patt)
mkPatt [Ident]
scope Patt
p
in ([Ident]
scope',Patt -> Patt
C.PImplArg Patt
p')
A.PTilde Type
t -> ( [Ident]
scope,Expr -> Patt
C.PTilde ([Ident] -> Type -> Expr
mkExp [Ident]
scope Type
t))
mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
mkContext :: [Ident] -> Context -> ([Ident], [Hypo])
mkContext [Ident]
scope Context
hyps = ([Ident] -> (BindType, Ident, Type) -> ([Ident], Hypo))
-> [Ident] -> Context -> ([Ident], [Hypo])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\[Ident]
scope (BindType
bt,Ident
x,Type
ty) -> let ty' :: Type
ty' = [Ident] -> Type -> Type
mkType [Ident]
scope Type
ty
in if Ident
x Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
identW
then ( [Ident]
scope,(BindType
bt,Ident -> CId
i2i Ident
x,Type
ty'))
else (Ident
xIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:[Ident]
scope,(BindType
bt,Ident -> CId
i2i Ident
x,Type
ty'))) [Ident]
scope Context
hyps
mkDef :: SourceGrammar
-> Int -> Maybe [L ([Patt], Type)] -> Maybe ([Equation], [[Instr]])
mkDef SourceGrammar
gr Int
arity (Just [L ([Patt], Type)]
eqs) = ([Equation], [[Instr]]) -> Maybe ([Equation], [[Instr]])
forall a. a -> Maybe a
Just ([[Patt] -> Expr -> Equation
C.Equ [Patt]
ps' ([Ident] -> Type -> Expr
mkExp [Ident]
scope' Type
e) | L Location
_ ([Patt]
ps,Type
e) <- [L ([Patt], Type)]
eqs, let ([Ident]
scope',[Patt]
ps') = ([Ident] -> Patt -> ([Ident], Patt))
-> [Ident] -> [Patt] -> ([Ident], [Patt])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL [Ident] -> Patt -> ([Ident], Patt)
mkPatt [] [Patt]
ps]
,SourceGrammar -> Int -> [L ([Patt], Type)] -> [[Instr]]
generateByteCode SourceGrammar
gr Int
arity [L ([Patt], Type)]
eqs
)
mkDef SourceGrammar
gr Int
arity Maybe [L ([Patt], Type)]
Nothing = Maybe ([Equation], [[Instr]])
forall a. Maybe a
Nothing
mkArity :: Maybe Int -> Maybe a -> Type -> Int
mkArity (Just Int
a) Maybe a
_ Type
ty = Int
a
mkArity Maybe Int
Nothing (Just a
_) Type
ty = Int
0
mkArity Maybe Int
Nothing Maybe a
_ Type
ty = let (Context
ctxt, (ModuleName, Ident)
_, [Type]
_) = Type -> (Context, (ModuleName, Ident), [Type])
GM.typeForm Type
ty
in Context -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Context
ctxt
genCncCats :: SourceGrammar
-> p -> p -> [((a, Ident), Info)] -> (Int, Map CId CncCat)
genCncCats SourceGrammar
gr p
am p
cm [((a, Ident), Info)]
cdefs =
let (Int
index,[(CId, CncCat)]
cats) = Int -> [((a, Ident), Info)] -> (Int, [(CId, CncCat)])
forall a. Int -> [((a, Ident), Info)] -> (Int, [(CId, CncCat)])
mkCncCats Int
0 [((a, Ident), Info)]
cdefs
in (Int
index, [(CId, CncCat)] -> Map CId CncCat
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(CId, CncCat)]
cats)
where
mkCncCats :: Int -> [((a, Ident), Info)] -> (Int, [(CId, CncCat)])
mkCncCats Int
index [] = (Int
index,[])
mkCncCats Int
index (((a
m,Ident
id),CncCat (Just (L Location
_ Type
lincat)) Maybe (L Type)
_ Maybe (L Type)
_ Maybe (L Type)
_ Maybe PMCFG
_):[((a, Ident), Info)]
cdefs)
| Ident
id Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cInt =
let cc :: CncCat
cc = SourceGrammar -> Type -> Int -> CncCat
pgfCncCat SourceGrammar
gr Type
lincat Int
fidInt
(Int
index',[(CId, CncCat)]
cats) = Int -> [((a, Ident), Info)] -> (Int, [(CId, CncCat)])
mkCncCats Int
index [((a, Ident), Info)]
cdefs
in (Int
index', (Ident -> CId
i2i Ident
id,CncCat
cc) (CId, CncCat) -> [(CId, CncCat)] -> [(CId, CncCat)]
forall a. a -> [a] -> [a]
: [(CId, CncCat)]
cats)
| Ident
id Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cFloat =
let cc :: CncCat
cc = SourceGrammar -> Type -> Int -> CncCat
pgfCncCat SourceGrammar
gr Type
lincat Int
fidFloat
(Int
index',[(CId, CncCat)]
cats) = Int -> [((a, Ident), Info)] -> (Int, [(CId, CncCat)])
mkCncCats Int
index [((a, Ident), Info)]
cdefs
in (Int
index', (Ident -> CId
i2i Ident
id,CncCat
cc) (CId, CncCat) -> [(CId, CncCat)] -> [(CId, CncCat)]
forall a. a -> [a] -> [a]
: [(CId, CncCat)]
cats)
| Ident
id Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cString =
let cc :: CncCat
cc = SourceGrammar -> Type -> Int -> CncCat
pgfCncCat SourceGrammar
gr Type
lincat Int
fidString
(Int
index',[(CId, CncCat)]
cats) = Int -> [((a, Ident), Info)] -> (Int, [(CId, CncCat)])
mkCncCats Int
index [((a, Ident), Info)]
cdefs
in (Int
index', (Ident -> CId
i2i Ident
id,CncCat
cc) (CId, CncCat) -> [(CId, CncCat)] -> [(CId, CncCat)]
forall a. a -> [a] -> [a]
: [(CId, CncCat)]
cats)
| Bool
otherwise =
let cc :: CncCat
cc@(C.CncCat Int
_s Int
e Array Int String
_) = SourceGrammar -> Type -> Int -> CncCat
pgfCncCat SourceGrammar
gr Type
lincat Int
index
(Int
index',[(CId, CncCat)]
cats) = Int -> [((a, Ident), Info)] -> (Int, [(CId, CncCat)])
mkCncCats (Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [((a, Ident), Info)]
cdefs
in (Int
index', (Ident -> CId
i2i Ident
id,CncCat
cc) (CId, CncCat) -> [(CId, CncCat)] -> [(CId, CncCat)]
forall a. a -> [a] -> [a]
: [(CId, CncCat)]
cats)
mkCncCats Int
index (((a, Ident), Info)
_ :[((a, Ident), Info)]
cdefs) = Int -> [((a, Ident), Info)] -> (Int, [(CId, CncCat)])
mkCncCats Int
index [((a, Ident), Info)]
cdefs
genCncFuns :: Grammar
-> ModuleName
-> ModuleName
-> Array SeqId Sequence
-> (Sequence -> Sequence -> Ordering)
-> Array SeqId Sequence
-> [(QIdent, Info)]
-> FId
-> Map.Map CId D.CncCat
-> (FId,
IntMap.IntMap (Set.Set D.Production),
IntMap.IntMap [FunId],
IntMap.IntMap [FunId],
Array FunId D.CncFun)
genCncFuns :: SourceGrammar
-> ModuleName
-> ModuleName
-> Array Int (Array Int Symbol)
-> (Array Int Symbol -> Array Int Symbol -> Ordering)
-> Array Int (Array Int Symbol)
-> [((ModuleName, Ident), Info)]
-> Int
-> Map CId CncCat
-> (Int, IntMap (Set Production), IntMap [Int], IntMap [Int],
Array Int CncFun)
genCncFuns SourceGrammar
gr ModuleName
am ModuleName
cm Array Int (Array Int Symbol)
ex_seqs Array Int Symbol -> Array Int Symbol -> Ordering
ciCmp Array Int (Array Int Symbol)
seqs [((ModuleName, Ident), Info)]
cdefs Int
fid_cnt Map CId CncCat
cnccats =
let (Int
fid_cnt1,Int
funs_cnt1,[(Int, CncFun)]
funs1,IntMap [Int]
lindefs,IntMap [Int]
linrefs) = [((ModuleName, Ident), Info)]
-> Int
-> Int
-> [(Int, CncFun)]
-> IntMap [Int]
-> IntMap [Int]
-> (Int, Int, [(Int, CncFun)], IntMap [Int], IntMap [Int])
forall t.
[((ModuleName, Ident), Info)]
-> t
-> Int
-> [(Int, CncFun)]
-> IntMap [Int]
-> IntMap [Int]
-> (t, Int, [(Int, CncFun)], IntMap [Int], IntMap [Int])
mkCncCats [((ModuleName, Ident), Info)]
cdefs Int
fid_cnt Int
0 [] IntMap [Int]
forall a. IntMap a
IntMap.empty IntMap [Int]
forall a. IntMap a
IntMap.empty
(Int
fid_cnt2,Int
funs_cnt2,[(Int, CncFun)]
funs2,IntMap (Set Production)
prods) = [((ModuleName, Ident), Info)]
-> Int
-> Int
-> [(Int, CncFun)]
-> IntMap [Int]
-> Map [Int] Int
-> IntMap (Set Production)
-> (Int, Int, [(Int, CncFun)], IntMap (Set Production))
forall a.
[((ModuleName, Ident), Info)]
-> Int
-> Int
-> [(Int, CncFun)]
-> IntMap a
-> Map [Int] Int
-> IntMap (Set Production)
-> (Int, Int, [(Int, CncFun)], IntMap (Set Production))
mkCncFuns [((ModuleName, Ident), Info)]
cdefs Int
fid_cnt1 Int
funs_cnt1 [(Int, CncFun)]
funs1 IntMap [Int]
lindefs Map [Int] Int
forall k a. Map k a
Map.empty IntMap (Set Production)
forall a. IntMap a
IntMap.empty
in (Int
fid_cnt2,IntMap (Set Production)
prods,IntMap [Int]
lindefs,IntMap [Int]
linrefs,(Int, Int) -> [(Int, CncFun)] -> Array Int CncFun
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Int
0,Int
funs_cnt2Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [(Int, CncFun)]
funs2)
where
mkCncCats :: [((ModuleName, Ident), Info)]
-> t
-> Int
-> [(Int, CncFun)]
-> IntMap [Int]
-> IntMap [Int]
-> (t, Int, [(Int, CncFun)], IntMap [Int], IntMap [Int])
mkCncCats [] t
fid_cnt Int
funs_cnt [(Int, CncFun)]
funs IntMap [Int]
lindefs IntMap [Int]
linrefs =
(t
fid_cnt,Int
funs_cnt,[(Int, CncFun)]
funs,IntMap [Int]
lindefs,IntMap [Int]
linrefs)
mkCncCats (((ModuleName
m,Ident
id),CncCat Maybe (L Type)
_ Maybe (L Type)
_ Maybe (L Type)
_ Maybe (L Type)
_ (Just (PMCFG [Production]
prods0 Array Int (UArray Int Int)
funs0))):[((ModuleName, Ident), Info)]
cdefs) t
fid_cnt Int
funs_cnt [(Int, CncFun)]
funs IntMap [Int]
lindefs IntMap [Int]
linrefs =
let !funs_cnt' :: Int
funs_cnt' = let (Int
s_funid, Int
e_funid) = Array Int (UArray Int Int) -> (Int, Int)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array Int (UArray Int Int)
funs0
in Int
funs_cntInt -> Int -> Int
forall a. Num a => a -> a -> a
+(Int
e_funidInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
s_funidInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
lindefs' :: IntMap [Int]
lindefs' = (IntMap [Int] -> Production -> IntMap [Int])
-> IntMap [Int] -> [Production] -> IntMap [Int]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((ModuleName, Ident)
-> Int -> IntMap [Int] -> Production -> IntMap [Int]
forall a.
(a, Ident) -> Int -> IntMap [Int] -> Production -> IntMap [Int]
toLinDef (ModuleName
am,Ident
id) Int
funs_cnt) IntMap [Int]
lindefs [Production]
prods0
linrefs' :: IntMap [Int]
linrefs' = (IntMap [Int] -> Production -> IntMap [Int])
-> IntMap [Int] -> [Production] -> IntMap [Int]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((ModuleName, Ident)
-> Int -> IntMap [Int] -> Production -> IntMap [Int]
forall a.
(a, Ident) -> Int -> IntMap [Int] -> Production -> IntMap [Int]
toLinRef (ModuleName
am,Ident
id) Int
funs_cnt) IntMap [Int]
linrefs [Production]
prods0
funs' :: [(Int, CncFun)]
funs' = ([(Int, CncFun)] -> (Int, UArray Int Int) -> [(Int, CncFun)])
-> [(Int, CncFun)] -> [(Int, UArray Int Int)] -> [(Int, CncFun)]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int
-> (ModuleName, Ident)
-> [(Int, CncFun)]
-> (Int, UArray Int Int)
-> [(Int, CncFun)]
forall a.
Num a =>
a
-> (ModuleName, Ident)
-> [(a, CncFun)]
-> (a, UArray Int Int)
-> [(a, CncFun)]
toCncFun Int
funs_cnt (ModuleName
m,Ident -> Ident
mkLinDefId Ident
id)) [(Int, CncFun)]
funs (Array Int (UArray Int Int) -> [(Int, UArray Int Int)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs Array Int (UArray Int Int)
funs0)
in [((ModuleName, Ident), Info)]
-> t
-> Int
-> [(Int, CncFun)]
-> IntMap [Int]
-> IntMap [Int]
-> (t, Int, [(Int, CncFun)], IntMap [Int], IntMap [Int])
mkCncCats [((ModuleName, Ident), Info)]
cdefs t
fid_cnt Int
funs_cnt' [(Int, CncFun)]
funs' IntMap [Int]
lindefs' IntMap [Int]
linrefs'
mkCncCats (((ModuleName, Ident), Info)
_ :[((ModuleName, Ident), Info)]
cdefs) t
fid_cnt Int
funs_cnt [(Int, CncFun)]
funs IntMap [Int]
lindefs IntMap [Int]
linrefs =
[((ModuleName, Ident), Info)]
-> t
-> Int
-> [(Int, CncFun)]
-> IntMap [Int]
-> IntMap [Int]
-> (t, Int, [(Int, CncFun)], IntMap [Int], IntMap [Int])
mkCncCats [((ModuleName, Ident), Info)]
cdefs t
fid_cnt Int
funs_cnt [(Int, CncFun)]
funs IntMap [Int]
lindefs IntMap [Int]
linrefs
mkCncFuns :: [((ModuleName, Ident), Info)]
-> Int
-> Int
-> [(Int, CncFun)]
-> IntMap a
-> Map [Int] Int
-> IntMap (Set Production)
-> (Int, Int, [(Int, CncFun)], IntMap (Set Production))
mkCncFuns [] Int
fid_cnt Int
funs_cnt [(Int, CncFun)]
funs IntMap a
lindefs Map [Int] Int
crc IntMap (Set Production)
prods =
(Int
fid_cnt,Int
funs_cnt,[(Int, CncFun)]
funs,IntMap (Set Production)
prods)
mkCncFuns (((ModuleName
m,Ident
id),CncFun Maybe (Ident, Context, Type)
_ Maybe (L Type)
_ Maybe (L Type)
_ (Just (PMCFG [Production]
prods0 Array Int (UArray Int Int)
funs0))):[((ModuleName, Ident), Info)]
cdefs) Int
fid_cnt Int
funs_cnt [(Int, CncFun)]
funs IntMap a
lindefs Map [Int] Int
crc IntMap (Set Production)
prods =
let
ty_C :: (Context, (ModuleName, Ident), [Type])
ty_C = (String -> (Context, (ModuleName, Ident), [Type]))
-> ((Context, (ModuleName, Ident), [Type])
-> (Context, (ModuleName, Ident), [Type]))
-> Err (Context, (ModuleName, Ident), [Type])
-> (Context, (ModuleName, Ident), [Type])
forall b a. (String -> b) -> (a -> b) -> Err a -> b
err String -> (Context, (ModuleName, Ident), [Type])
forall a. HasCallStack => String -> a
error (\(Context, (ModuleName, Ident), [Type])
x -> (Context, (ModuleName, Ident), [Type])
x) (Err (Context, (ModuleName, Ident), [Type])
-> (Context, (ModuleName, Ident), [Type]))
-> Err (Context, (ModuleName, Ident), [Type])
-> (Context, (ModuleName, Ident), [Type])
forall a b. (a -> b) -> a -> b
$ (Type -> (Context, (ModuleName, Ident), [Type]))
-> Err Type -> Err (Context, (ModuleName, Ident), [Type])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> (Context, (ModuleName, Ident), [Type])
GM.typeForm (SourceGrammar -> ModuleName -> Ident -> Err Type
forall (m :: * -> *).
ErrorMonad m =>
SourceGrammar -> ModuleName -> Ident -> m Type
Look.lookupFunType SourceGrammar
gr ModuleName
am Ident
id)
!funs_cnt' :: Int
funs_cnt' = let (Int
s_funid, Int
e_funid) = Array Int (UArray Int Int) -> (Int, Int)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array Int (UArray Int Int)
funs0
in Int
funs_cntInt -> Int -> Int
forall a. Num a => a -> a -> a
+(Int
e_funidInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
s_funidInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
!(Int
fid_cnt',Map [Int] Int
crc',IntMap (Set Production)
prods')
= ((Int, Map [Int] Int, IntMap (Set Production))
-> Production -> (Int, Map [Int] Int, IntMap (Set Production)))
-> (Int, Map [Int] Int, IntMap (Set Production))
-> [Production]
-> (Int, Map [Int] Int, IntMap (Set Production))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IntMap a
-> (Context, (ModuleName, Ident), [Type])
-> Int
-> (Int, Map [Int] Int, IntMap (Set Production))
-> Production
-> (Int, Map [Int] Int, IntMap (Set Production))
forall a a b a c.
IntMap a
-> ([(a, b, Type)], (a, Ident), c)
-> Int
-> (Int, Map [Int] Int, IntMap (Set Production))
-> Production
-> (Int, Map [Int] Int, IntMap (Set Production))
toProd IntMap a
lindefs (Context, (ModuleName, Ident), [Type])
ty_C Int
funs_cnt)
(Int
fid_cnt,Map [Int] Int
crc,IntMap (Set Production)
prods) [Production]
prods0
funs' :: [(Int, CncFun)]
funs' = ([(Int, CncFun)] -> (Int, UArray Int Int) -> [(Int, CncFun)])
-> [(Int, CncFun)] -> [(Int, UArray Int Int)] -> [(Int, CncFun)]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int
-> (ModuleName, Ident)
-> [(Int, CncFun)]
-> (Int, UArray Int Int)
-> [(Int, CncFun)]
forall a.
Num a =>
a
-> (ModuleName, Ident)
-> [(a, CncFun)]
-> (a, UArray Int Int)
-> [(a, CncFun)]
toCncFun Int
funs_cnt (ModuleName
m,Ident
id)) [(Int, CncFun)]
funs (Array Int (UArray Int Int) -> [(Int, UArray Int Int)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs Array Int (UArray Int Int)
funs0)
in [((ModuleName, Ident), Info)]
-> Int
-> Int
-> [(Int, CncFun)]
-> IntMap a
-> Map [Int] Int
-> IntMap (Set Production)
-> (Int, Int, [(Int, CncFun)], IntMap (Set Production))
mkCncFuns [((ModuleName, Ident), Info)]
cdefs Int
fid_cnt' Int
funs_cnt' [(Int, CncFun)]
funs' IntMap a
lindefs Map [Int] Int
crc' IntMap (Set Production)
prods'
mkCncFuns (((ModuleName, Ident), Info)
_ :[((ModuleName, Ident), Info)]
cdefs) Int
fid_cnt Int
funs_cnt [(Int, CncFun)]
funs IntMap a
lindefs Map [Int] Int
crc IntMap (Set Production)
prods =
[((ModuleName, Ident), Info)]
-> Int
-> Int
-> [(Int, CncFun)]
-> IntMap a
-> Map [Int] Int
-> IntMap (Set Production)
-> (Int, Int, [(Int, CncFun)], IntMap (Set Production))
mkCncFuns [((ModuleName, Ident), Info)]
cdefs Int
fid_cnt Int
funs_cnt [(Int, CncFun)]
funs IntMap a
lindefs Map [Int] Int
crc IntMap (Set Production)
prods
toProd :: IntMap a
-> ([(a, b, Type)], (a, Ident), c)
-> Int
-> (Int, Map [Int] Int, IntMap (Set Production))
-> Production
-> (Int, Map [Int] Int, IntMap (Set Production))
toProd IntMap a
lindefs ([(a, b, Type)]
ctxt_C,(a, Ident)
res_C,c
_) Int
offs (Int, Map [Int] Int, IntMap (Set Production))
st (Production Int
fid0 Int
funid0 [[Int]]
args0) =
let !((Int
fid_cnt,Map [Int] Int
crc,IntMap (Set Production)
prods),[[PArg]]
args) = ((Int, Map [Int] Int, IntMap (Set Production))
-> ((a, b, Type), [Int])
-> ((Int, Map [Int] Int, IntMap (Set Production)), [PArg]))
-> (Int, Map [Int] Int, IntMap (Set Production))
-> [((a, b, Type), [Int])]
-> ((Int, Map [Int] Int, IntMap (Set Production)), [[PArg]])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (Int, Map [Int] Int, IntMap (Set Production))
-> ((a, b, Type), [Int])
-> ((Int, Map [Int] Int, IntMap (Set Production)), [PArg])
forall a b.
(Int, Map [Int] Int, IntMap (Set Production))
-> ((a, b, Type), [Int])
-> ((Int, Map [Int] Int, IntMap (Set Production)), [PArg])
mkArg (Int, Map [Int] Int, IntMap (Set Production))
st ([(a, b, Type)] -> [[Int]] -> [((a, b, Type), [Int])]
forall a b. [a] -> [b] -> [(a, b)]
zip [(a, b, Type)]
ctxt_C [[Int]]
args0)
set0 :: Set Production
set0 = [Production] -> Set Production
forall a. Ord a => [a] -> Set a
Set.fromList (([PArg] -> Production) -> [[PArg]] -> [Production]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [PArg] -> Production
C.PApply (Int
offsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
funid0)) ([[PArg]] -> [[PArg]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [[PArg]]
args))
fid :: Int
fid = (a, Ident) -> Int -> Int
forall a. (a, Ident) -> Int -> Int
mkFId (a, Ident)
res_C Int
fid0
!prods' :: IntMap (Set Production)
prods' = case Int -> IntMap (Set Production) -> Maybe (Set Production)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
fid IntMap (Set Production)
prods of
Just Set Production
set -> Int
-> Set Production
-> IntMap (Set Production)
-> IntMap (Set Production)
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
fid (Set Production -> Set Production -> Set Production
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Production
set0 Set Production
set) IntMap (Set Production)
prods
Maybe (Set Production)
Nothing -> Int
-> Set Production
-> IntMap (Set Production)
-> IntMap (Set Production)
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
fid Set Production
set0 IntMap (Set Production)
prods
in (Int
fid_cnt,Map [Int] Int
crc,IntMap (Set Production)
prods')
where
mkArg :: (Int, Map [Int] Int, IntMap (Set Production))
-> ((a, b, Type), [Int])
-> ((Int, Map [Int] Int, IntMap (Set Production)), [PArg])
mkArg st :: (Int, Map [Int] Int, IntMap (Set Production))
st@(Int
fid_cnt,Map [Int] Int
crc,IntMap (Set Production)
prods) ((a
_,b
_,Type
ty),[Int]
fid0s ) =
case [Int]
fid0s of
[Int
fid0] -> ((Int, Map [Int] Int, IntMap (Set Production))
st,([(Int, Int)] -> PArg) -> [[(Int, Int)]] -> [PArg]
forall a b. (a -> b) -> [a] -> [b]
map (([(Int, Int)] -> Int -> PArg) -> Int -> [(Int, Int)] -> PArg
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(Int, Int)] -> Int -> PArg
C.PArg ((ModuleName, Ident) -> Int -> Int
forall a. (a, Ident) -> Int -> Int
mkFId (ModuleName, Ident)
arg_C Int
fid0)) [[(Int, Int)]]
ctxt)
[Int]
fid0s -> case [Int] -> Map [Int] Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [Int]
fids Map [Int] Int
crc of
Just Int
fid -> ((Int, Map [Int] Int, IntMap (Set Production))
st,([(Int, Int)] -> PArg) -> [[(Int, Int)]] -> [PArg]
forall a b. (a -> b) -> [a] -> [b]
map (([(Int, Int)] -> Int -> PArg) -> Int -> [(Int, Int)] -> PArg
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(Int, Int)] -> Int -> PArg
C.PArg Int
fid) [[(Int, Int)]]
ctxt)
Maybe Int
Nothing -> let !crc' :: Map [Int] Int
crc' = [Int] -> Int -> Map [Int] Int -> Map [Int] Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert [Int]
fids Int
fid_cnt Map [Int] Int
crc
!prods' :: IntMap (Set Production)
prods' = Int
-> Set Production
-> IntMap (Set Production)
-> IntMap (Set Production)
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
fid_cnt ([Production] -> Set Production
forall a. Ord a => [a] -> Set a
Set.fromList ((Int -> Production) -> [Int] -> [Production]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Production
C.PCoerce [Int]
fids)) IntMap (Set Production)
prods
in ((Int
fid_cntInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Map [Int] Int
crc',IntMap (Set Production)
prods'),([(Int, Int)] -> PArg) -> [[(Int, Int)]] -> [PArg]
forall a b. (a -> b) -> [a] -> [b]
map (([(Int, Int)] -> Int -> PArg) -> Int -> [(Int, Int)] -> PArg
forall a b c. (a -> b -> c) -> b -> a -> c
flip [(Int, Int)] -> Int -> PArg
C.PArg Int
fid_cnt) [[(Int, Int)]]
ctxt)
where
([(ModuleName, Ident)]
hargs_C,(ModuleName, Ident)
arg_C) = Type -> ([(ModuleName, Ident)], (ModuleName, Ident))
GM.catSkeleton Type
ty
ctxt :: [[(Int, Int)]]
ctxt = ((ModuleName, Ident) -> [(Int, Int)])
-> [(ModuleName, Ident)] -> [[(Int, Int)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IntMap a -> (ModuleName, Ident) -> [(Int, Int)]
forall a a. IntMap a -> (a, Ident) -> [(Int, Int)]
mkCtxt IntMap a
lindefs) [(ModuleName, Ident)]
hargs_C
fids :: [Int]
fids = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((ModuleName, Ident) -> Int -> Int
forall a. (a, Ident) -> Int -> Int
mkFId (ModuleName, Ident)
arg_C) [Int]
fid0s
mkLinDefId :: Ident -> Ident
mkLinDefId Ident
id = String -> Ident -> Ident
prefixIdent String
"lindef " Ident
id
toLinDef :: (a, Ident) -> Int -> IntMap [Int] -> Production -> IntMap [Int]
toLinDef (a, Ident)
res Int
offs IntMap [Int]
lindefs (Production Int
fid0 Int
funid0 [[Int]]
args) =
if [[Int]]
args [[Int]] -> [[Int]] -> Bool
forall a. Eq a => a -> a -> Bool
== [[Int
fidVar]]
then ([Int] -> [Int] -> [Int])
-> Int -> [Int] -> IntMap [Int] -> IntMap [Int]
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IntMap.insertWith [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
(++) Int
fid [Int
offsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
funid0] IntMap [Int]
lindefs
else IntMap [Int]
lindefs
where
fid :: Int
fid = (a, Ident) -> Int -> Int
forall a. (a, Ident) -> Int -> Int
mkFId (a, Ident)
res Int
fid0
toLinRef :: (a, Ident) -> Int -> IntMap [Int] -> Production -> IntMap [Int]
toLinRef (a, Ident)
res Int
offs IntMap [Int]
linrefs (Production Int
fid0 Int
funid0 [[Int]
fargs]) =
if Int
fid0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
fidVar
then (Int -> IntMap [Int] -> IntMap [Int])
-> IntMap [Int] -> [Int] -> IntMap [Int]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Int
fid -> ([Int] -> [Int] -> [Int])
-> Int -> [Int] -> IntMap [Int] -> IntMap [Int]
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IntMap.insertWith [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
(++) Int
fid [Int
offsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
funid0]) IntMap [Int]
linrefs [Int]
fids
else IntMap [Int]
linrefs
where
fids :: [Int]
fids = (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((a, Ident) -> Int -> Int
forall a. (a, Ident) -> Int -> Int
mkFId (a, Ident)
res) [Int]
fargs
mkFId :: (a, Ident) -> Int -> Int
mkFId (a
_,Ident
cat) Int
fid0 =
case CId -> Map CId CncCat -> Maybe CncCat
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Ident -> CId
i2i Ident
cat) Map CId CncCat
cnccats of
Just (C.CncCat Int
s Int
e Array Int String
_) -> Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
fid0
Maybe CncCat
Nothing -> String -> Int
forall a. HasCallStack => String -> a
error (String
"GrammarToPGF.mkFId: missing category "String -> String -> String
forall a. [a] -> [a] -> [a]
++Ident -> String
showIdent Ident
cat)
mkCtxt :: IntMap a -> (a, Ident) -> [(Int, Int)]
mkCtxt IntMap a
lindefs (a
_,Ident
cat) =
case CId -> Map CId CncCat -> Maybe CncCat
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Ident -> CId
i2i Ident
cat) Map CId CncCat
cnccats of
Just (C.CncCat Int
s Int
e Array Int String
_) -> [(Int
C.fidVar,Int
fid) | Int
fid <- [Int
s..Int
e], Just a
_ <- [Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
fid IntMap a
lindefs]]
Maybe CncCat
Nothing -> String -> [(Int, Int)]
forall a. HasCallStack => String -> a
error String
"GrammarToPGF.mkCtxt failed"
toCncFun :: a
-> (ModuleName, Ident)
-> [(a, CncFun)]
-> (a, UArray Int Int)
-> [(a, CncFun)]
toCncFun a
offs (ModuleName
m,Ident
id) [(a, CncFun)]
funs (a
funid0,UArray Int Int
lins0) =
let mseqs :: Array Int (Array Int Symbol)
mseqs = case SourceGrammar -> ModuleName -> Err ModuleInfo
forall (m :: * -> *).
ErrorMonad m =>
SourceGrammar -> ModuleName -> m ModuleInfo
lookupModule SourceGrammar
gr ModuleName
m of
Ok (ModInfo{mseqs :: ModuleInfo -> Maybe (Array Int (Array Int Symbol))
mseqs=Just Array Int (Array Int Symbol)
mseqs}) -> Array Int (Array Int Symbol)
mseqs
Err ModuleInfo
_ -> Array Int (Array Int Symbol)
ex_seqs
in (a
offsa -> a -> a
forall a. Num a => a -> a -> a
+a
funid0,CId -> UArray Int Int -> CncFun
C.CncFun (Ident -> CId
i2i Ident
id) ((Int -> Int) -> UArray Int Int -> UArray Int Int
forall (a :: * -> * -> *) e' e i.
(IArray a e', IArray a e, Ix i) =>
(e' -> e) -> a i e' -> a i e
amap (Array Int (Array Int Symbol) -> Int -> Int
forall (a :: * -> * -> *) i.
(IArray a (Array Int Symbol), Ix i) =>
a i (Array Int Symbol) -> i -> Int
newIndex Array Int (Array Int Symbol)
mseqs) UArray Int Int
lins0))(a, CncFun) -> [(a, CncFun)] -> [(a, CncFun)]
forall a. a -> [a] -> [a]
:[(a, CncFun)]
funs
where
newIndex :: a i (Array Int Symbol) -> i -> Int
newIndex a i (Array Int Symbol)
mseqs i
i = Array Int Symbol
-> Array Int (Array Int Symbol) -> (Int, Int) -> Int
forall a (a :: * -> * -> *).
(IArray a (Array Int Symbol), Ix a, Integral a) =>
Array Int Symbol -> a a (Array Int Symbol) -> (a, a) -> a
binSearch (a i (Array Int Symbol)
mseqs a i (Array Int Symbol) -> i -> Array Int Symbol
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! i
i) Array Int (Array Int Symbol)
seqs (Array Int (Array Int Symbol) -> (Int, Int)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array Int (Array Int Symbol)
seqs)
binSearch :: Array Int Symbol -> a a (Array Int Symbol) -> (a, a) -> a
binSearch Array Int Symbol
v a a (Array Int Symbol)
arr (a
i,a
j)
| a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
j = case Array Int Symbol -> Array Int Symbol -> Ordering
ciCmp Array Int Symbol
v (a a (Array Int Symbol)
arr a a (Array Int Symbol) -> a -> Array Int Symbol
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! a
k) of
Ordering
LT -> Array Int Symbol -> a a (Array Int Symbol) -> (a, a) -> a
binSearch Array Int Symbol
v a a (Array Int Symbol)
arr (a
i,a
ka -> a -> a
forall a. Num a => a -> a -> a
-a
1)
Ordering
EQ -> a
k
Ordering
GT -> Array Int Symbol -> a a (Array Int Symbol) -> (a, a) -> a
binSearch Array Int Symbol
v a a (Array Int Symbol)
arr (a
ka -> a -> a
forall a. Num a => a -> a -> a
+a
1,a
j)
| Bool
otherwise = String -> a
forall a. HasCallStack => String -> a
error String
"binSearch"
where
k :: a
k = (a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
j) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
2
genPrintNames :: [((a, Ident), Info)] -> Map CId String
genPrintNames [((a, Ident), Info)]
cdefs =
[(CId, String)] -> Map CId String
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [(Ident -> CId
i2i Ident
id, String
name) | ((a
m,Ident
id),Info
info) <- [((a, Ident), Info)]
cdefs, String
name <- Info -> [String]
prn Info
info]
where
prn :: Info -> [String]
prn (CncFun Maybe (Ident, Context, Type)
_ Maybe (L Type)
_ (Just (L Location
_ Type
tr)) Maybe PMCFG
_) = [Type -> String
flatten Type
tr]
prn (CncCat Maybe (L Type)
_ Maybe (L Type)
_ Maybe (L Type)
_ (Just (L Location
_ Type
tr)) Maybe PMCFG
_) = [Type -> String
flatten Type
tr]
prn Info
_ = []
flatten :: Type -> String
flatten (K String
s) = String
s
flatten (Alts Type
x [(Type, Type)]
_) = Type -> String
flatten Type
x
flatten (C Type
x Type
y) = Type -> String
flatten Type
x String -> String -> String
+++ Type -> String
flatten Type
y
mkArray :: [e] -> a Int e
mkArray [e]
lst = (Int, Int) -> [e] -> a Int e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
0,[e] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [e]
lstInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [e]
lst
mkMapArray :: Map e Int -> a Int e
mkMapArray Map e Int
map = (Int, Int) -> [(Int, e)] -> a Int e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Int
0,Map e Int -> Int
forall k a. Map k a -> Int
Map.size Map e Int
mapInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [(Int
v,e
k) | (e
k,Int
v) <- Map e Int -> [(e, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Map e Int
map]