{-# LANGUAGE BangPatterns, FlexibleContexts #-}
module GF.Compile.GrammarToPGF (mkCanon2pgf) where

--import GF.Compile.Export
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
        -- if some module was compiled with -no-pmcfg, then
        -- we have to create the PMCFG code just before linking
        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   -- known arity, i.e. defined function
mkArity Maybe Int
Nothing  (Just a
_) Type
ty = Int
0   -- defined function with no arity - must be an axiom
mkArity Maybe Int
Nothing  Maybe a
_        Type
ty = let (Context
ctxt, (ModuleName, Ident)
_, [Type]
_) = Type -> (Context, (ModuleName, Ident), [Type])
GM.typeForm Type
ty  -- constructor
                               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 ---Ok ty_C        = fmap GM.typeForm (Look.lookupFunType gr am id)
          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]