{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
----------------------------------------------------------------------
-- |
-- Maintainer  : Krasimir Angelov
-- Stability   : (stable)
-- Portability : (portable)
--
-- Convert PGF grammar to PMCFG grammar.
--
-----------------------------------------------------------------------------

module GF.Compile.GeneratePMCFG
    (generatePMCFG, pgfCncCat, addPMCFG, resourceValues
    ) where

--import PGF.CId
import PGF.Internal as PGF(CncCat(..),Symbol(..),fidVar)

import GF.Infra.Option
import GF.Grammar hiding (Env, mkRecord, mkTable)
import GF.Grammar.Lookup
import GF.Grammar.Predef
import GF.Grammar.Lockfield (isLockLabel)
import GF.Data.BacktrackM
import GF.Data.Operations
import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
import GF.Data.Utilities (updateNthM) --updateNth
import GF.Compile.Compute.Concrete(normalForm,resourceValues)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.List as List
--import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import GF.Text.Pretty
import Data.Array.IArray
import Data.Array.Unboxed
--import Data.Maybe
--import Data.Char (isDigit)
import Control.Applicative(Applicative(..))
import Control.Monad
import Control.Monad.Identity
--import Control.Exception
--import Debug.Trace(trace)
import qualified Control.Monad.Fail as Fail

----------------------------------------------------------------------
-- main conversion function

--generatePMCFG :: Options -> SourceGrammar -> Maybe FilePath -> SourceModule -> IOE SourceModule
generatePMCFG :: Options
-> Grammar
-> Maybe FilePath
-> (ModuleName, ModuleInfo)
-> m (ModuleName, ModuleInfo)
generatePMCFG Options
opts Grammar
sgr Maybe FilePath
opath cmo :: (ModuleName, ModuleInfo)
cmo@(ModuleName
cm,ModuleInfo
cmi) = do
  (SeqSet
seqs,Map Ident Info
js) <- (SeqSet -> Ident -> Info -> m (SeqSet, Info))
-> SeqSet -> Map Ident Info -> m (SeqSet, Map Ident Info)
forall (m :: * -> *) k a b c.
(Monad m, Ord k) =>
(a -> k -> b -> m (a, c)) -> a -> Map k b -> m (a, Map k c)
mapAccumWithKeyM (Options
-> Grammar
-> GlobalEnv
-> Maybe FilePath
-> ModuleName
-> ModuleName
-> SeqSet
-> Ident
-> Info
-> m (SeqSet, Info)
forall (m :: * -> *) p.
(MonadFail m, Output m) =>
Options
-> Grammar
-> GlobalEnv
-> Maybe FilePath
-> ModuleName
-> p
-> SeqSet
-> Ident
-> Info
-> m (SeqSet, Info)
addPMCFG Options
opts Grammar
gr GlobalEnv
cenv Maybe FilePath
opath ModuleName
am ModuleName
cm) SeqSet
forall k a. Map k a
Map.empty (ModuleInfo -> Map Ident Info
jments ModuleInfo
cmi)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Verbose) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall (m :: * -> *). Output m => FilePath -> m ()
ePutStrLn FilePath
""
  (ModuleName, ModuleInfo) -> m (ModuleName, ModuleInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
cm,ModuleInfo
cmi{mseqs :: Maybe (Array SeqId Sequence)
mseqs = Array SeqId Sequence -> Maybe (Array SeqId Sequence)
forall a. a -> Maybe a
Just (SeqSet -> Array SeqId Sequence
forall (a :: * -> * -> *) e. IArray a e => Map e SeqId -> a SeqId e
mkSetArray SeqSet
seqs), jments :: Map Ident Info
jments = Map Ident Info
js})
  where
    cenv :: GlobalEnv
cenv = Options -> Grammar -> GlobalEnv
resourceValues Options
opts Grammar
gr
    gr :: Grammar
gr = Grammar -> (ModuleName, ModuleInfo) -> Grammar
prependModule Grammar
sgr (ModuleName, ModuleInfo)
cmo
    MTConcrete ModuleName
am = ModuleInfo -> ModuleType
mtype ModuleInfo
cmi

mapAccumWithKeyM :: (Monad m, Ord k) => (a -> k -> b -> m (a,c)) -> a
                                     -> Map.Map k b -> m (a,Map.Map k c)
mapAccumWithKeyM :: (a -> k -> b -> m (a, c)) -> a -> Map k b -> m (a, Map k c)
mapAccumWithKeyM a -> k -> b -> m (a, c)
f a
a Map k b
m = do let xs :: [(k, b)]
xs = Map k b -> [(k, b)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map k b
m
                            (a
a,[(k, c)]
ys) <- (a -> k -> b -> m (a, c)) -> a -> [(k, b)] -> m (a, [(k, c)])
forall (m :: * -> *) t a t b.
Monad m =>
(t -> a -> t -> m (t, b)) -> t -> [(a, t)] -> m (t, [(a, b)])
mapAccumM a -> k -> b -> m (a, c)
f a
a [(k, b)]
xs
                            (a, Map k c) -> m (a, Map k c)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,[(k, c)] -> Map k c
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [(k, c)]
ys)
  where
    mapAccumM :: (t -> a -> t -> m (t, b)) -> t -> [(a, t)] -> m (t, [(a, b)])
mapAccumM t -> a -> t -> m (t, b)
f t
a []          = (t, [(a, b)]) -> m (t, [(a, b)])
forall (m :: * -> *) a. Monad m => a -> m a
return (t
a,[])
    mapAccumM t -> a -> t -> m (t, b)
f t
a ((a
k,t
x):[(a, t)]
kxs) = do (t
a,b
y ) <- t -> a -> t -> m (t, b)
f t
a a
k t
x
                                   (t
a,[(a, b)]
kys) <- (t -> a -> t -> m (t, b)) -> t -> [(a, t)] -> m (t, [(a, b)])
mapAccumM t -> a -> t -> m (t, b)
f t
a [(a, t)]
kxs
                                   (t, [(a, b)]) -> m (t, [(a, b)])
forall (m :: * -> *) a. Monad m => a -> m a
return (t
a,(a
k,b
y)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
kys)


--addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Maybe FilePath -> Ident -> Ident -> SeqSet -> Ident -> Info -> IOE (SeqSet, Info)
addPMCFG :: Options
-> Grammar
-> GlobalEnv
-> Maybe FilePath
-> ModuleName
-> p
-> SeqSet
-> Ident
-> Info
-> m (SeqSet, Info)
addPMCFG Options
opts Grammar
gr GlobalEnv
cenv Maybe FilePath
opath ModuleName
am p
cm SeqSet
seqs Ident
id (GF.Grammar.CncFun mty :: Maybe (Ident, Context, Type)
mty@(Just (Ident
cat,Context
cont,Type
val)) mlin :: Maybe (L Type)
mlin@(Just (L Location
loc Type
term)) Maybe (L Type)
mprn Maybe PMCFG
Nothing) = do
--when (verbAtLeast opts Verbose) $ ePutStr ("\n+ "++showIdent id++" ...")
  let pres :: ProtoFCat
pres  = Grammar -> Cat -> Type -> ProtoFCat
protoFCat Grammar
gr Cat
res Type
val
      pargs :: [ProtoFCat]
pargs = [Grammar -> Cat -> Type -> ProtoFCat
protoFCat Grammar
gr (([Cat], Cat) -> Cat
forall a b. (a, b) -> b
snd (([Cat], Cat) -> Cat) -> ([Cat], Cat) -> Cat
forall a b. (a -> b) -> a -> b
$ Type -> ([Cat], Cat)
catSkeleton Type
ty) Type
lincat | ((BindType
_,Ident
_,Type
ty),(BindType
_,Ident
_,Type
lincat)) <- Context -> Context -> [(Hypo, Hypo)]
forall a b. [a] -> [b] -> [(a, b)]
zip Context
ctxt Context
cont]

      pmcfgEnv0 :: PMCFGEnv
pmcfgEnv0   = PMCFGEnv
emptyPMCFGEnv
  Branch (Value [Symbol])
b             <- Options
-> Grammar
-> GlobalEnv
-> L Ident
-> Type
-> (Context, Type)
-> [ProtoFCat]
-> m (Branch (Value [Symbol]))
forall (m :: * -> *) a c.
MonadFail m =>
Options
-> Grammar
-> GlobalEnv
-> L Ident
-> Type
-> ([(a, Ident, c)], Type)
-> [ProtoFCat]
-> m (Branch (Value [Symbol]))
convert Options
opts Grammar
gr GlobalEnv
cenv (Maybe FilePath -> Location -> Ident -> L Ident
forall a. Maybe FilePath -> Location -> a -> L a
floc Maybe FilePath
opath Location
loc Ident
id) Type
term (Context
cont,Type
val) [ProtoFCat]
pargs
  let (SeqSet
seqs1,Branch (Value SeqId)
b1) = SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
addSequencesB SeqSet
seqs Branch (Value [Symbol])
b
      pmcfgEnv1 :: PMCFGEnv
pmcfgEnv1  = ([SeqId] -> (ProtoFCat, [ProtoFCat]) -> PMCFGEnv -> PMCFGEnv)
-> PMCFGEnv
-> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
-> (ProtoFCat, [ProtoFCat])
-> PMCFGEnv
forall a s b. (a -> s -> b -> b) -> b -> BacktrackM s a -> s -> b
foldBM [SeqId] -> (ProtoFCat, [ProtoFCat]) -> PMCFGEnv -> PMCFGEnv
addRule
                          PMCFGEnv
pmcfgEnv0
                          (Branch (Value SeqId)
-> Path -> [SeqId] -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
goB Branch (Value SeqId)
b1 Path
CNil [])
                          (ProtoFCat
pres,[ProtoFCat]
pargs)
      pmcfg :: PMCFG
pmcfg      = PMCFGEnv -> PMCFG
getPMCFG PMCFGEnv
pmcfgEnv1

      stats :: (SeqId, SeqId)
stats      = let PMCFG [Production]
prods Array SeqId (UArray SeqId SeqId)
funs = PMCFG
pmcfg
                       (SeqId
s,SeqId
e)            = Array SeqId (UArray SeqId SeqId) -> (SeqId, SeqId)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds Array SeqId (UArray SeqId SeqId)
funs
                       !prods_cnt :: SeqId
prods_cnt       = [Production] -> SeqId
forall (t :: * -> *) a. Foldable t => t a -> SeqId
length [Production]
prods
                       !funs_cnt :: SeqId
funs_cnt        = SeqId
eSeqId -> SeqId -> SeqId
forall a. Num a => a -> a -> a
-SeqId
sSeqId -> SeqId -> SeqId
forall a. Num a => a -> a -> a
+SeqId
1
                   in (SeqId
prods_cnt,SeqId
funs_cnt)

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Verbose) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> m ()
forall (m :: * -> *). Output m => FilePath -> m ()
ePutStr (FilePath
"\n+ "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Ident -> FilePath
showIdent Ident
idFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++SeqId -> FilePath
forall a. Show a => a -> FilePath
show ([SeqId] -> SeqId
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ((ProtoFCat -> SeqId) -> [ProtoFCat] -> [SeqId]
forall a b. (a -> b) -> [a] -> [b]
map ProtoFCat -> SeqId
catFactor [ProtoFCat]
pargs)))
  SeqSet
seqs1 SeqSet -> m () -> m ()
`seq` (SeqId, SeqId)
stats (SeqId, SeqId) -> m () -> m ()
`seq` () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Verbose) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall (m :: * -> *). Output m => FilePath -> m ()
ePutStr (FilePath
" "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++(SeqId, SeqId) -> FilePath
forall a. Show a => a -> FilePath
show (SeqId, SeqId)
stats)
  (SeqSet, Info) -> m (SeqSet, Info)
forall (m :: * -> *) a. Monad m => a -> m a
return (SeqSet
seqs1,Maybe (Ident, Context, Type)
-> Maybe (L Type) -> Maybe (L Type) -> Maybe PMCFG -> Info
GF.Grammar.CncFun Maybe (Ident, Context, Type)
mty Maybe (L Type)
mlin Maybe (L Type)
mprn (PMCFG -> Maybe PMCFG
forall a. a -> Maybe a
Just PMCFG
pmcfg))
  where
    (Context
ctxt,Cat
res,[Type]
_) = (FilePath -> (Context, Cat, [Type]))
-> (Type -> (Context, Cat, [Type]))
-> Err Type
-> (Context, Cat, [Type])
forall b a. (FilePath -> b) -> (a -> b) -> Err a -> b
err FilePath -> (Context, Cat, [Type])
forall a a. Pretty a => a -> a
bug Type -> (Context, Cat, [Type])
typeForm (Grammar -> ModuleName -> Ident -> Err Type
forall (m :: * -> *).
ErrorMonad m =>
Grammar -> ModuleName -> Ident -> m Type
lookupFunType Grammar
gr ModuleName
am Ident
id)

    addRule :: [SeqId] -> (ProtoFCat, [ProtoFCat]) -> PMCFGEnv -> PMCFGEnv
addRule [SeqId]
lins (ProtoFCat
newCat', [ProtoFCat]
newArgs') PMCFGEnv
env0 =
      let [SeqId
newCat] = ProtoFCat -> [SeqId]
getFIds ProtoFCat
newCat'
          !fun :: UArray SeqId SeqId
fun     = [SeqId] -> UArray SeqId SeqId
forall (a :: * -> * -> *) e. IArray a e => [e] -> a SeqId e
mkArray [SeqId]
lins
          newArgs :: [[SeqId]]
newArgs  = (ProtoFCat -> [SeqId]) -> [ProtoFCat] -> [[SeqId]]
forall a b. (a -> b) -> [a] -> [b]
map ProtoFCat -> [SeqId]
getFIds [ProtoFCat]
newArgs'
      in PMCFGEnv -> SeqId -> UArray SeqId SeqId -> [[SeqId]] -> PMCFGEnv
addFunction PMCFGEnv
env0 SeqId
newCat UArray SeqId SeqId
fun [[SeqId]]
newArgs

addPMCFG Options
opts Grammar
gr GlobalEnv
cenv Maybe FilePath
opath ModuleName
am p
cm SeqSet
seqs Ident
id (GF.Grammar.CncCat mty :: Maybe (L Type)
mty@(Just (L Location
_ Type
lincat))
                                                             mdef :: Maybe (L Type)
mdef@(Just (L Location
loc1 Type
def))
                                                             mref :: Maybe (L Type)
mref@(Just (L Location
loc2 Type
ref))
                                                             Maybe (L Type)
mprn
                                                             Maybe PMCFG
Nothing) = do
  let pcat :: ProtoFCat
pcat = Grammar -> Cat -> Type -> ProtoFCat
protoFCat Grammar
gr (ModuleName
am,Ident
id) Type
lincat
      pvar :: ProtoFCat
pvar = Grammar -> Cat -> Type -> ProtoFCat
protoFCat Grammar
gr (Ident -> ModuleName
MN Ident
identW,Ident
cVar) Type
typeStr

      pmcfgEnv0 :: PMCFGEnv
pmcfgEnv0  = PMCFGEnv
emptyPMCFGEnv

  let lincont :: Context
lincont    = [(BindType
Explicit, Ident
varStr, Type
typeStr)]
  Branch (Value [Symbol])
b             <- Options
-> Grammar
-> GlobalEnv
-> L Ident
-> Type
-> (Context, Type)
-> [ProtoFCat]
-> m (Branch (Value [Symbol]))
forall (m :: * -> *) a c.
MonadFail m =>
Options
-> Grammar
-> GlobalEnv
-> L Ident
-> Type
-> ([(a, Ident, c)], Type)
-> [ProtoFCat]
-> m (Branch (Value [Symbol]))
convert Options
opts Grammar
gr GlobalEnv
cenv (Maybe FilePath -> Location -> Ident -> L Ident
forall a. Maybe FilePath -> Location -> a -> L a
floc Maybe FilePath
opath Location
loc1 Ident
id) Type
def (Context
lincont,Type
lincat) [ProtoFCat
pvar]
  let (SeqSet
seqs1,Branch (Value SeqId)
b1) = SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
addSequencesB SeqSet
seqs Branch (Value [Symbol])
b
      pmcfgEnv1 :: PMCFGEnv
pmcfgEnv1  = ([SeqId] -> (ProtoFCat, [ProtoFCat]) -> PMCFGEnv -> PMCFGEnv)
-> PMCFGEnv
-> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
-> (ProtoFCat, [ProtoFCat])
-> PMCFGEnv
forall a s b. (a -> s -> b -> b) -> b -> BacktrackM s a -> s -> b
foldBM [SeqId] -> (ProtoFCat, [ProtoFCat]) -> PMCFGEnv -> PMCFGEnv
forall b. [SeqId] -> (ProtoFCat, b) -> PMCFGEnv -> PMCFGEnv
addLindef
                          PMCFGEnv
pmcfgEnv0
                          (Branch (Value SeqId)
-> Path -> [SeqId] -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
goB Branch (Value SeqId)
b1 Path
CNil [])
                          (ProtoFCat
pcat,[ProtoFCat
pvar])

  let lincont :: Context
lincont    = [(BindType
Explicit, Ident
varStr, Type
lincat)]
  Branch (Value [Symbol])
b             <- Options
-> Grammar
-> GlobalEnv
-> L Ident
-> Type
-> (Context, Type)
-> [ProtoFCat]
-> m (Branch (Value [Symbol]))
forall (m :: * -> *) a c.
MonadFail m =>
Options
-> Grammar
-> GlobalEnv
-> L Ident
-> Type
-> ([(a, Ident, c)], Type)
-> [ProtoFCat]
-> m (Branch (Value [Symbol]))
convert Options
opts Grammar
gr GlobalEnv
cenv (Maybe FilePath -> Location -> Ident -> L Ident
forall a. Maybe FilePath -> Location -> a -> L a
floc Maybe FilePath
opath Location
loc2 Ident
id) Type
ref (Context
lincont,Type
typeStr) [ProtoFCat
pcat]
  let (SeqSet
seqs2,Branch (Value SeqId)
b2) = SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
addSequencesB SeqSet
seqs1 Branch (Value [Symbol])
b
      pmcfgEnv2 :: PMCFGEnv
pmcfgEnv2  = ([SeqId] -> (ProtoFCat, [ProtoFCat]) -> PMCFGEnv -> PMCFGEnv)
-> PMCFGEnv
-> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
-> (ProtoFCat, [ProtoFCat])
-> PMCFGEnv
forall a s b. (a -> s -> b -> b) -> b -> BacktrackM s a -> s -> b
foldBM [SeqId] -> (ProtoFCat, [ProtoFCat]) -> PMCFGEnv -> PMCFGEnv
forall a. [SeqId] -> (a, [ProtoFCat]) -> PMCFGEnv -> PMCFGEnv
addLinref
                          PMCFGEnv
pmcfgEnv1
                          (Branch (Value SeqId)
-> Path -> [SeqId] -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
goB Branch (Value SeqId)
b2 Path
CNil [])
                          (ProtoFCat
pvar,[ProtoFCat
pcat])

  let pmcfg :: PMCFG
pmcfg     = PMCFGEnv -> PMCFG
getPMCFG PMCFGEnv
pmcfgEnv2

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Options -> Verbosity -> Bool
verbAtLeast Options
opts Verbosity
Verbose) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> m ()
forall (m :: * -> *). Output m => FilePath -> m ()
ePutStr (FilePath
"\n+ "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Ident -> FilePath
showIdent Ident
idFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++SeqId -> FilePath
forall a. Show a => a -> FilePath
show (ProtoFCat -> SeqId
catFactor ProtoFCat
pcat))
  SeqSet
seqs2 SeqSet -> m (SeqSet, Info) -> m (SeqSet, Info)
`seq` PMCFG
pmcfg PMCFG -> m (SeqSet, Info) -> m (SeqSet, Info)
`seq` (SeqSet, Info) -> m (SeqSet, Info)
forall (m :: * -> *) a. Monad m => a -> m a
return (SeqSet
seqs2,Maybe (L Type)
-> Maybe (L Type)
-> Maybe (L Type)
-> Maybe (L Type)
-> Maybe PMCFG
-> Info
GF.Grammar.CncCat Maybe (L Type)
mty Maybe (L Type)
mdef Maybe (L Type)
mref Maybe (L Type)
mprn (PMCFG -> Maybe PMCFG
forall a. a -> Maybe a
Just PMCFG
pmcfg))
  where
    addLindef :: [SeqId] -> (ProtoFCat, b) -> PMCFGEnv -> PMCFGEnv
addLindef [SeqId]
lins (ProtoFCat
newCat', b
newArgs') PMCFGEnv
env0 =
      let [SeqId
newCat] = ProtoFCat -> [SeqId]
getFIds ProtoFCat
newCat'
          !fun :: UArray SeqId SeqId
fun     = [SeqId] -> UArray SeqId SeqId
forall (a :: * -> * -> *) e. IArray a e => [e] -> a SeqId e
mkArray [SeqId]
lins
      in PMCFGEnv -> SeqId -> UArray SeqId SeqId -> [[SeqId]] -> PMCFGEnv
addFunction PMCFGEnv
env0 SeqId
newCat UArray SeqId SeqId
fun [[SeqId
fidVar]]

    addLinref :: [SeqId] -> (a, [ProtoFCat]) -> PMCFGEnv -> PMCFGEnv
addLinref [SeqId]
lins (a
newCat', [ProtoFCat
newArg']) PMCFGEnv
env0 =
      let newArg :: [SeqId]
newArg   = ProtoFCat -> [SeqId]
getFIds ProtoFCat
newArg'
          !fun :: UArray SeqId SeqId
fun     = [SeqId] -> UArray SeqId SeqId
forall (a :: * -> * -> *) e. IArray a e => [e] -> a SeqId e
mkArray [SeqId]
lins
      in PMCFGEnv -> SeqId -> UArray SeqId SeqId -> [[SeqId]] -> PMCFGEnv
addFunction PMCFGEnv
env0 SeqId
fidVar UArray SeqId SeqId
fun [[SeqId]
newArg]

addPMCFG Options
opts Grammar
gr GlobalEnv
cenv Maybe FilePath
opath ModuleName
am p
cm SeqSet
seqs Ident
id Info
info = (SeqSet, Info) -> m (SeqSet, Info)
forall (m :: * -> *) a. Monad m => a -> m a
return (SeqSet
seqs, Info
info)

floc :: Maybe FilePath -> Location -> a -> L a
floc Maybe FilePath
opath Location
loc a
id = L a -> (FilePath -> L a) -> Maybe FilePath -> L a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Location -> a -> L a
forall a. Location -> a -> L a
L Location
loc a
id) (\FilePath
path->Location -> a -> L a
forall a. Location -> a -> L a
L (FilePath -> Location -> Location
External FilePath
path Location
loc) a
id) Maybe FilePath
opath

convert :: Options
-> Grammar
-> GlobalEnv
-> L Ident
-> Type
-> ([(a, Ident, c)], Type)
-> [ProtoFCat]
-> m (Branch (Value [Symbol]))
convert Options
opts Grammar
gr GlobalEnv
cenv L Ident
loc Type
term ty :: ([(a, Ident, c)], Type)
ty@([(a, Ident, c)]
_,Type
val) [ProtoFCat]
pargs =
  case GlobalEnv -> L Ident -> Type -> Type
normalForm GlobalEnv
cenv L Ident
loc (([(a, Ident, c)], Type) -> Type -> Type
forall a c b. ([(a, Ident, c)], b) -> Type -> Type
etaExpand ([(a, Ident, c)], Type)
ty Type
term) of
    Error FilePath
s -> FilePath -> m (Branch (Value [Symbol]))
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m (Branch (Value [Symbol])))
-> FilePath -> m (Branch (Value [Symbol]))
forall a b. (a -> b) -> a -> b
$ Doc -> FilePath
forall a. Pretty a => a -> FilePath
render (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$ L Ident -> FilePath -> Doc
forall a1 a3. (Pretty a1, Pretty a3) => L a3 -> a1 -> Doc
ppL L Ident
loc (FilePath
"Predef.error: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
s)
    Type
term    -> Branch (Value [Symbol]) -> m (Branch (Value [Symbol]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Branch (Value [Symbol]) -> m (Branch (Value [Symbol])))
-> Branch (Value [Symbol]) -> m (Branch (Value [Symbol]))
forall a b. (a -> b) -> a -> b
$ Grammar
-> CnvMonad (Value [Symbol])
-> ([ProtoFCat], [Symbol])
-> Branch (Value [Symbol])
forall a.
Grammar -> CnvMonad a -> ([ProtoFCat], [Symbol]) -> Branch a
runCnvMonad Grammar
gr (Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
CNil Type
val Type
term) ([ProtoFCat]
pargs,[])
  where
    etaExpand :: ([(a, Ident, c)], b) -> Type -> Type
etaExpand ([(a, Ident, c)]
context,b
val) = [(BindType, Ident)] -> Type -> Type
mkAbs [(BindType, Ident)]
pars (Type -> Type) -> (Type -> Type) -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> [Type] -> Type) -> [Type] -> Type -> Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> [Type] -> Type
mkApp [Type]
args
      where pars :: [(BindType, Ident)]
pars = [(BindType
Explicit,Ident
v) | Ident
v <- [Ident]
vars]
            args :: [Type]
args = (Ident -> Type) -> [Ident] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Type
Vr [Ident]
vars
            vars :: [Ident]
vars = ((a, Ident, c) -> Ident) -> [(a, Ident, c)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
bt,Ident
x,c
t) -> Ident
x) [(a, Ident, c)]
context

pgfCncCat :: SourceGrammar -> Type -> Int -> CncCat
pgfCncCat :: Grammar -> Type -> SeqId -> CncCat
pgfCncCat Grammar
gr Type
lincat SeqId
index =
  let ((Integer
_,SeqId
size),Schema Identity Integer (SeqId, [(Type, Integer)])
schema) = Grammar
-> Type
-> ((Integer, SeqId),
    Schema Identity Integer (SeqId, [(Type, Integer)]))
forall s b.
(Num s, Num b, Enum b) =>
Grammar
-> Type -> ((s, SeqId), Schema Identity s (SeqId, [(Type, b)]))
computeCatRange Grammar
gr Type
lincat
  in SeqId -> SeqId -> Array SeqId FilePath -> CncCat
PGF.CncCat SeqId
index (SeqId
indexSeqId -> SeqId -> SeqId
forall a. Num a => a -> a -> a
+SeqId
sizeSeqId -> SeqId -> SeqId
forall a. Num a => a -> a -> a
-SeqId
1)
                      ([FilePath] -> Array SeqId FilePath
forall (a :: * -> * -> *) e. IArray a e => [e] -> a SeqId e
mkArray ((Path -> FilePath) -> [Path] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Style -> Doc -> FilePath
forall a. Pretty a => Style -> a -> FilePath
renderStyle Style
style{mode :: Mode
mode=Mode
OneLineMode} (Doc -> FilePath) -> (Path -> Doc) -> Path -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Doc
ppPath)
                                    (Schema Identity Integer (SeqId, [(Type, Integer)]) -> [Path]
forall s c. Schema Identity s c -> [Path]
getStrPaths Schema Identity Integer (SeqId, [(Type, Integer)])
schema)))
  where
    getStrPaths :: Schema Identity s c -> [Path]
    getStrPaths :: Schema Identity s c -> [Path]
getStrPaths = Path -> [Path] -> Schema Identity s c -> [Path]
forall s c. Path -> [Path] -> Schema Identity s c -> [Path]
collect Path
CNil []
      where
        collect :: Path -> [Path] -> Schema Identity s c -> [Path]
collect Path
path [Path]
paths (CRec [(Label, Identity (Schema Identity s c))]
rs)   = ((Label, Identity (Schema Identity s c)) -> [Path] -> [Path])
-> [Path] -> [(Label, Identity (Schema Identity s c))] -> [Path]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Label
lbl,Identity Schema Identity s c
t) [Path]
paths -> Path -> [Path] -> Schema Identity s c -> [Path]
collect (Label -> Path -> Path
CProj Label
lbl Path
path) [Path]
paths Schema Identity s c
t) [Path]
paths [(Label, Identity (Schema Identity s c))]
rs
        collect Path
path [Path]
paths (CTbl Type
_ [(Type, Identity (Schema Identity s c))]
cs) = ((Type, Identity (Schema Identity s c)) -> [Path] -> [Path])
-> [Path] -> [(Type, Identity (Schema Identity s c))] -> [Path]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Type
trm,Identity Schema Identity s c
t) [Path]
paths -> Path -> [Path] -> Schema Identity s c -> [Path]
collect (Type -> Path -> Path
CSel  Type
trm Path
path) [Path]
paths Schema Identity s c
t) [Path]
paths [(Type, Identity (Schema Identity s c))]
cs
        collect Path
path [Path]
paths (CStr s
_)    = Path -> Path
reversePath Path
path Path -> [Path] -> [Path]
forall a. a -> [a] -> [a]
: [Path]
paths
        collect Path
path [Path]
paths (CPar c
_)    = [Path]
paths

----------------------------------------------------------------------
-- CnvMonad monad
--
-- The branching monad provides backtracking together with
-- recording of the choices made. We have two cases
-- when we have alternative choices:
--
--      * when we have parameter type, then
--        we have to try all possible values
--      * when we have variants we have to try all alternatives
--
-- The conversion monad keeps track of the choices and they are
-- returned as 'Branch' data type.

data Branch a
  = Case Int Path [(Term,Branch a)]
  | Variant [Branch a]
  | Return  a

newtype CnvMonad a = CM {CnvMonad a
-> Grammar
-> forall b.
   (a -> ([ProtoFCat], [Symbol]) -> Branch b)
   -> ([ProtoFCat], [Symbol]) -> Branch b
unCM :: SourceGrammar
                              -> forall b . (a -> ([ProtoFCat],[Symbol]) -> Branch b)
                              -> ([ProtoFCat],[Symbol])
                              -> Branch b}

instance Fail.MonadFail CnvMonad where
  fail :: FilePath -> CnvMonad a
fail = FilePath -> CnvMonad a
forall a a. Pretty a => a -> a
bug

instance Applicative CnvMonad where
  pure :: a -> CnvMonad a
pure = a -> CnvMonad a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: CnvMonad (a -> b) -> CnvMonad a -> CnvMonad b
(<*>) = CnvMonad (a -> b) -> CnvMonad a -> CnvMonad b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad CnvMonad where
    return :: a -> CnvMonad a
return a
a   = (Grammar
 -> forall b.
    (a -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad a
forall a.
(Grammar
 -> forall b.
    (a -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad a
CM (\Grammar
gr a -> ([ProtoFCat], [Symbol]) -> Branch b
c ([ProtoFCat], [Symbol])
s -> a -> ([ProtoFCat], [Symbol]) -> Branch b
c a
a ([ProtoFCat], [Symbol])
s)
    CM Grammar
-> forall b.
   (a -> ([ProtoFCat], [Symbol]) -> Branch b)
   -> ([ProtoFCat], [Symbol]) -> Branch b
m >>= :: CnvMonad a -> (a -> CnvMonad b) -> CnvMonad b
>>= a -> CnvMonad b
k = (Grammar
 -> forall b.
    (b -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad b
forall a.
(Grammar
 -> forall b.
    (a -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad a
CM (\Grammar
gr b -> ([ProtoFCat], [Symbol]) -> Branch b
c ([ProtoFCat], [Symbol])
s -> Grammar
-> (a -> ([ProtoFCat], [Symbol]) -> Branch b)
-> ([ProtoFCat], [Symbol])
-> Branch b
Grammar
-> forall b.
   (a -> ([ProtoFCat], [Symbol]) -> Branch b)
   -> ([ProtoFCat], [Symbol]) -> Branch b
m Grammar
gr (\a
a ([ProtoFCat], [Symbol])
s -> CnvMonad b
-> Grammar
-> (b -> ([ProtoFCat], [Symbol]) -> Branch b)
-> ([ProtoFCat], [Symbol])
-> Branch b
forall a.
CnvMonad a
-> Grammar
-> forall b.
   (a -> ([ProtoFCat], [Symbol]) -> Branch b)
   -> ([ProtoFCat], [Symbol]) -> Branch b
unCM (a -> CnvMonad b
k a
a) Grammar
gr b -> ([ProtoFCat], [Symbol]) -> Branch b
c ([ProtoFCat], [Symbol])
s) ([ProtoFCat], [Symbol])
s)

instance MonadState ([ProtoFCat],[Symbol]) CnvMonad where
    get :: CnvMonad ([ProtoFCat], [Symbol])
get = (Grammar
 -> forall b.
    (([ProtoFCat], [Symbol]) -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad ([ProtoFCat], [Symbol])
forall a.
(Grammar
 -> forall b.
    (a -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad a
CM (\Grammar
gr ([ProtoFCat], [Symbol]) -> ([ProtoFCat], [Symbol]) -> Branch b
c ([ProtoFCat], [Symbol])
s -> ([ProtoFCat], [Symbol]) -> ([ProtoFCat], [Symbol]) -> Branch b
c ([ProtoFCat], [Symbol])
s ([ProtoFCat], [Symbol])
s)
    put :: ([ProtoFCat], [Symbol]) -> CnvMonad ()
put ([ProtoFCat], [Symbol])
s = (Grammar
 -> forall b.
    (() -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad ()
forall a.
(Grammar
 -> forall b.
    (a -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad a
CM (\Grammar
gr () -> ([ProtoFCat], [Symbol]) -> Branch b
c ([ProtoFCat], [Symbol])
_ -> () -> ([ProtoFCat], [Symbol]) -> Branch b
c () ([ProtoFCat], [Symbol])
s)

instance Functor CnvMonad where
    fmap :: (a -> b) -> CnvMonad a -> CnvMonad b
fmap a -> b
f (CM Grammar
-> forall b.
   (a -> ([ProtoFCat], [Symbol]) -> Branch b)
   -> ([ProtoFCat], [Symbol]) -> Branch b
m) = (Grammar
 -> forall b.
    (b -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad b
forall a.
(Grammar
 -> forall b.
    (a -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad a
CM (\Grammar
gr b -> ([ProtoFCat], [Symbol]) -> Branch b
c ([ProtoFCat], [Symbol])
s -> Grammar
-> (a -> ([ProtoFCat], [Symbol]) -> Branch b)
-> ([ProtoFCat], [Symbol])
-> Branch b
Grammar
-> forall b.
   (a -> ([ProtoFCat], [Symbol]) -> Branch b)
   -> ([ProtoFCat], [Symbol]) -> Branch b
m Grammar
gr (b -> ([ProtoFCat], [Symbol]) -> Branch b
c (b -> ([ProtoFCat], [Symbol]) -> Branch b)
-> (a -> b) -> a -> ([ProtoFCat], [Symbol]) -> Branch b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) ([ProtoFCat], [Symbol])
s)

runCnvMonad :: SourceGrammar -> CnvMonad a -> ([ProtoFCat],[Symbol]) -> Branch a
runCnvMonad :: Grammar -> CnvMonad a -> ([ProtoFCat], [Symbol]) -> Branch a
runCnvMonad Grammar
gr (CM Grammar
-> forall b.
   (a -> ([ProtoFCat], [Symbol]) -> Branch b)
   -> ([ProtoFCat], [Symbol]) -> Branch b
m) ([ProtoFCat], [Symbol])
s = Grammar
-> (a -> ([ProtoFCat], [Symbol]) -> Branch a)
-> ([ProtoFCat], [Symbol])
-> Branch a
Grammar
-> forall b.
   (a -> ([ProtoFCat], [Symbol]) -> Branch b)
   -> ([ProtoFCat], [Symbol]) -> Branch b
m Grammar
gr (\a
v ([ProtoFCat], [Symbol])
s -> a -> Branch a
forall a. a -> Branch a
Return a
v) ([ProtoFCat], [Symbol])
s

-- | backtracking for all variants
variants :: [a] -> CnvMonad a
variants :: [a] -> CnvMonad a
variants [a]
xs = (Grammar
 -> forall b.
    (a -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad a
forall a.
(Grammar
 -> forall b.
    (a -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad a
CM (\Grammar
gr a -> ([ProtoFCat], [Symbol]) -> Branch b
c ([ProtoFCat], [Symbol])
s -> [Branch b] -> Branch b
forall a. [Branch a] -> Branch a
Variant [a -> ([ProtoFCat], [Symbol]) -> Branch b
c a
x ([ProtoFCat], [Symbol])
s | a
x <- [a]
xs])

-- | backtracking for all parameter values that a variable could take
choices :: Int -> Path -> CnvMonad Term
choices :: SeqId -> Path -> CnvMonad Type
choices SeqId
nr Path
path = do ([ProtoFCat]
args,[Symbol]
_) <- CnvMonad ([ProtoFCat], [Symbol])
forall s (m :: * -> *). MonadState s m => m s
get
                     let PFCat Ident
_ SeqId
_ Schema Identity SeqId (SeqId, [(Type, SeqId)])
schema = [ProtoFCat]
args [ProtoFCat] -> SeqId -> ProtoFCat
forall a. [a] -> SeqId -> a
!! SeqId
nr
                     Schema Identity SeqId (SeqId, [(Type, SeqId)])
-> Path -> Path -> CnvMonad Type
forall s a b.
Show s =>
Schema Identity s (a, [(Type, b)]) -> Path -> Path -> CnvMonad Type
descend Schema Identity SeqId (SeqId, [(Type, SeqId)])
schema Path
path Path
CNil
  where
    descend :: Schema Identity s (a, [(Type, b)]) -> Path -> Path -> CnvMonad Type
descend (CRec [(Label, Identity (Schema Identity s (a, [(Type, b)])))]
rs)     (CProj Label
lbl Path
path) Path
rpath = case Label
-> [(Label, Identity (Schema Identity s (a, [(Type, b)])))]
-> Maybe (Identity (Schema Identity s (a, [(Type, b)])))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Label
lbl [(Label, Identity (Schema Identity s (a, [(Type, b)])))]
rs of
                                                     Just (Identity Schema Identity s (a, [(Type, b)])
t) -> Schema Identity s (a, [(Type, b)]) -> Path -> Path -> CnvMonad Type
descend Schema Identity s (a, [(Type, b)])
t Path
path (Label -> Path -> Path
CProj Label
lbl Path
rpath)
    descend (CRec [(Label, Identity (Schema Identity s (a, [(Type, b)])))]
rs)     Path
CNil             Path
rpath = do [Assign]
rs <- ((Label, Identity (Schema Identity s (a, [(Type, b)])))
 -> CnvMonad Assign)
-> [(Label, Identity (Schema Identity s (a, [(Type, b)])))]
-> CnvMonad [Assign]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Label
lbl,Identity Schema Identity s (a, [(Type, b)])
t) -> (Type -> Assign) -> CnvMonad Type -> CnvMonad Assign
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Label -> Type -> Assign
assign Label
lbl) (Schema Identity s (a, [(Type, b)]) -> Path -> Path -> CnvMonad Type
descend Schema Identity s (a, [(Type, b)])
t Path
CNil (Label -> Path -> Path
CProj Label
lbl Path
rpath))) [(Label, Identity (Schema Identity s (a, [(Type, b)])))]
rs
                                                      Type -> CnvMonad Type
forall (m :: * -> *) a. Monad m => a -> m a
return ([Assign] -> Type
R [Assign]
rs)
    descend (CTbl Type
pt [(Type, Identity (Schema Identity s (a, [(Type, b)])))]
cs)  (CSel  Type
trm Path
path) Path
rpath = case Type
-> [(Type, Identity (Schema Identity s (a, [(Type, b)])))]
-> Maybe (Identity (Schema Identity s (a, [(Type, b)])))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Type
trm [(Type, Identity (Schema Identity s (a, [(Type, b)])))]
cs of
                                                     Just (Identity Schema Identity s (a, [(Type, b)])
t) -> Schema Identity s (a, [(Type, b)]) -> Path -> Path -> CnvMonad Type
descend Schema Identity s (a, [(Type, b)])
t Path
path (Type -> Path -> Path
CSel Type
trm Path
rpath)
    descend (CTbl Type
pt [(Type, Identity (Schema Identity s (a, [(Type, b)])))]
cs)  Path
CNil             Path
rpath = do [Type]
cs <- ((Type, Identity (Schema Identity s (a, [(Type, b)])))
 -> CnvMonad Type)
-> [(Type, Identity (Schema Identity s (a, [(Type, b)])))]
-> CnvMonad [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Type
trm,Identity Schema Identity s (a, [(Type, b)])
t) -> Schema Identity s (a, [(Type, b)]) -> Path -> Path -> CnvMonad Type
descend Schema Identity s (a, [(Type, b)])
t Path
CNil (Type -> Path -> Path
CSel Type
trm Path
rpath)) [(Type, Identity (Schema Identity s (a, [(Type, b)])))]
cs
                                                      Type -> CnvMonad Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> [Type] -> Type
V Type
pt [Type]
cs)
    descend (CPar (a
m,[(Type, b)]
vs)) Path
CNil             Path
rpath = case [(Type, b)]
vs of
                                                     [(Type
value,b
index)] -> Type -> CnvMonad Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
value
                                                     [(Type, b)]
values          -> let path :: Path
path = Path -> Path
reversePath Path
rpath
                                                                        in (Grammar
 -> forall b.
    (Type -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad Type
forall a.
(Grammar
 -> forall b.
    (a -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad a
CM (\Grammar
gr Type -> ([ProtoFCat], [Symbol]) -> Branch b
c ([ProtoFCat], [Symbol])
s -> SeqId -> Path -> [(Type, Branch b)] -> Branch b
forall a. SeqId -> Path -> [(Type, Branch a)] -> Branch a
Case SeqId
nr Path
path [(Type
value, Path
-> Type
-> Grammar
-> (Type -> ([ProtoFCat], [Symbol]) -> Branch b)
-> ([ProtoFCat], [Symbol])
-> Branch b
forall p b p.
Path
-> Type
-> p
-> (Type -> ([ProtoFCat], b) -> p)
-> ([ProtoFCat], b)
-> p
updateEnv Path
path Type
value Grammar
gr Type -> ([ProtoFCat], [Symbol]) -> Branch b
c ([ProtoFCat], [Symbol])
s)
                                                                                                                    | (Type
value,b
index) <- [(Type, b)]
values])
    descend Schema Identity s (a, [(Type, b)])
schema       Path
path              Path
rpath = FilePath -> CnvMonad Type
forall a a. Pretty a => a -> a
bug (FilePath -> CnvMonad Type) -> FilePath -> CnvMonad Type
forall a b. (a -> b) -> a -> b
$ FilePath
"descend "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++(Schema Identity s (a, [(Type, b)]), Path, Path) -> FilePath
forall a. Show a => a -> FilePath
show (Schema Identity s (a, [(Type, b)])
schema,Path
path,Path
rpath)

    updateEnv :: Path
-> Type
-> p
-> (Type -> ([ProtoFCat], b) -> p)
-> ([ProtoFCat], b)
-> p
updateEnv Path
path Type
value p
gr Type -> ([ProtoFCat], b) -> p
c ([ProtoFCat]
args,b
seq) =
      case (ProtoFCat -> Maybe ProtoFCat)
-> SeqId -> [ProtoFCat] -> Maybe [ProtoFCat]
forall (m :: * -> *) a.
Monad m =>
(a -> m a) -> SeqId -> [a] -> m [a]
updateNthM (Path -> Type -> ProtoFCat -> Maybe ProtoFCat
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Path -> Type -> ProtoFCat -> m ProtoFCat
restrictProtoFCat Path
path Type
value) SeqId
nr [ProtoFCat]
args of
        Just [ProtoFCat]
args -> Type -> ([ProtoFCat], b) -> p
c Type
value ([ProtoFCat]
args,b
seq)
        Maybe [ProtoFCat]
Nothing   -> FilePath -> p
forall a a. Pretty a => a -> a
bug FilePath
"conflict in updateEnv"

-- | the argument should be a parameter type and then
-- the function returns all possible values.
getAllParamValues :: Type -> CnvMonad [Term]
getAllParamValues :: Type -> CnvMonad [Type]
getAllParamValues Type
ty = (Grammar
 -> forall b.
    ([Type] -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad [Type]
forall a.
(Grammar
 -> forall b.
    (a -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad a
CM (\Grammar
gr [Type] -> ([ProtoFCat], [Symbol]) -> Branch b
c -> [Type] -> ([ProtoFCat], [Symbol]) -> Branch b
c ((FilePath -> [Type]) -> ([Type] -> [Type]) -> Err [Type] -> [Type]
forall b a. (FilePath -> b) -> (a -> b) -> Err a -> b
err FilePath -> [Type]
forall a a. Pretty a => a -> a
bug [Type] -> [Type]
forall a. a -> a
id (Grammar -> Type -> Err [Type]
forall (m :: * -> *). ErrorMonad m => Grammar -> Type -> m [Type]
allParamValues Grammar
gr Type
ty)))

mkRecord :: [(Label,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c)
mkRecord :: [(Label, CnvMonad (Schema Branch s c))]
-> CnvMonad (Schema Branch s c)
mkRecord [(Label, CnvMonad (Schema Branch s c))]
xs = (Grammar
 -> forall b.
    (Schema Branch s c -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad (Schema Branch s c)
forall a.
(Grammar
 -> forall b.
    (a -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad a
CM (\Grammar
gr Schema Branch s c -> ([ProtoFCat], [Symbol]) -> Branch b
c -> (([(Label, Branch (Schema Branch s c))]
  -> ([ProtoFCat], [Symbol]) -> Branch b)
 -> (Label, CnvMonad (Schema Branch s c))
 -> [(Label, Branch (Schema Branch s c))]
 -> ([ProtoFCat], [Symbol])
 -> Branch b)
-> ([(Label, Branch (Schema Branch s c))]
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> [(Label, CnvMonad (Schema Branch s c))]
-> [(Label, Branch (Schema Branch s c))]
-> ([ProtoFCat], [Symbol])
-> Branch b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\[(Label, Branch (Schema Branch s c))]
-> ([ProtoFCat], [Symbol]) -> Branch b
c (Label
lbl,CM Grammar
-> forall b.
   (Schema Branch s c -> ([ProtoFCat], [Symbol]) -> Branch b)
   -> ([ProtoFCat], [Symbol]) -> Branch b
m) [(Label, Branch (Schema Branch s c))]
bs ([ProtoFCat], [Symbol])
s -> [(Label, Branch (Schema Branch s c))]
-> ([ProtoFCat], [Symbol]) -> Branch b
c ((Label
lbl,Grammar
-> (Schema Branch s c
    -> ([ProtoFCat], [Symbol]) -> Branch (Schema Branch s c))
-> ([ProtoFCat], [Symbol])
-> Branch (Schema Branch s c)
Grammar
-> forall b.
   (Schema Branch s c -> ([ProtoFCat], [Symbol]) -> Branch b)
   -> ([ProtoFCat], [Symbol]) -> Branch b
m Grammar
gr (\Schema Branch s c
v ([ProtoFCat], [Symbol])
s -> Schema Branch s c -> Branch (Schema Branch s c)
forall a. a -> Branch a
Return Schema Branch s c
v) ([ProtoFCat], [Symbol])
s) (Label, Branch (Schema Branch s c))
-> [(Label, Branch (Schema Branch s c))]
-> [(Label, Branch (Schema Branch s c))]
forall a. a -> [a] -> [a]
: [(Label, Branch (Schema Branch s c))]
bs) ([ProtoFCat], [Symbol])
s) (Schema Branch s c -> ([ProtoFCat], [Symbol]) -> Branch b
c (Schema Branch s c -> ([ProtoFCat], [Symbol]) -> Branch b)
-> ([(Label, Branch (Schema Branch s c))] -> Schema Branch s c)
-> [(Label, Branch (Schema Branch s c))]
-> ([ProtoFCat], [Symbol])
-> Branch b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Label, Branch (Schema Branch s c))] -> Schema Branch s c
forall (b :: * -> *) s c.
[(Label, b (Schema b s c))] -> Schema b s c
CRec) [(Label, CnvMonad (Schema Branch s c))]
xs [])

mkTable  :: Type -> [(Term ,CnvMonad (Schema Branch s c))] -> CnvMonad (Schema Branch s c)
mkTable :: Type
-> [(Type, CnvMonad (Schema Branch s c))]
-> CnvMonad (Schema Branch s c)
mkTable Type
pt [(Type, CnvMonad (Schema Branch s c))]
xs = (Grammar
 -> forall b.
    (Schema Branch s c -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad (Schema Branch s c)
forall a.
(Grammar
 -> forall b.
    (a -> ([ProtoFCat], [Symbol]) -> Branch b)
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> CnvMonad a
CM (\Grammar
gr Schema Branch s c -> ([ProtoFCat], [Symbol]) -> Branch b
c -> (([(Type, Branch (Schema Branch s c))]
  -> ([ProtoFCat], [Symbol]) -> Branch b)
 -> (Type, CnvMonad (Schema Branch s c))
 -> [(Type, Branch (Schema Branch s c))]
 -> ([ProtoFCat], [Symbol])
 -> Branch b)
-> ([(Type, Branch (Schema Branch s c))]
    -> ([ProtoFCat], [Symbol]) -> Branch b)
-> [(Type, CnvMonad (Schema Branch s c))]
-> [(Type, Branch (Schema Branch s c))]
-> ([ProtoFCat], [Symbol])
-> Branch b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\[(Type, Branch (Schema Branch s c))]
-> ([ProtoFCat], [Symbol]) -> Branch b
c (Type
trm,CM Grammar
-> forall b.
   (Schema Branch s c -> ([ProtoFCat], [Symbol]) -> Branch b)
   -> ([ProtoFCat], [Symbol]) -> Branch b
m) [(Type, Branch (Schema Branch s c))]
bs ([ProtoFCat], [Symbol])
s -> [(Type, Branch (Schema Branch s c))]
-> ([ProtoFCat], [Symbol]) -> Branch b
c ((Type
trm,Grammar
-> (Schema Branch s c
    -> ([ProtoFCat], [Symbol]) -> Branch (Schema Branch s c))
-> ([ProtoFCat], [Symbol])
-> Branch (Schema Branch s c)
Grammar
-> forall b.
   (Schema Branch s c -> ([ProtoFCat], [Symbol]) -> Branch b)
   -> ([ProtoFCat], [Symbol]) -> Branch b
m Grammar
gr (\Schema Branch s c
v ([ProtoFCat], [Symbol])
s -> Schema Branch s c -> Branch (Schema Branch s c)
forall a. a -> Branch a
Return Schema Branch s c
v) ([ProtoFCat], [Symbol])
s) (Type, Branch (Schema Branch s c))
-> [(Type, Branch (Schema Branch s c))]
-> [(Type, Branch (Schema Branch s c))]
forall a. a -> [a] -> [a]
: [(Type, Branch (Schema Branch s c))]
bs) ([ProtoFCat], [Symbol])
s) (Schema Branch s c -> ([ProtoFCat], [Symbol]) -> Branch b
c (Schema Branch s c -> ([ProtoFCat], [Symbol]) -> Branch b)
-> ([(Type, Branch (Schema Branch s c))] -> Schema Branch s c)
-> [(Type, Branch (Schema Branch s c))]
-> ([ProtoFCat], [Symbol])
-> Branch b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [(Type, Branch (Schema Branch s c))] -> Schema Branch s c
forall (b :: * -> *) s c.
Type -> [(Type, b (Schema b s c))] -> Schema b s c
CTbl Type
pt) [(Type, CnvMonad (Schema Branch s c))]
xs [])

----------------------------------------------------------------------
-- Term Schema
--
-- The term schema is a term-like structure, with records, tables,
-- strings and parameters values, but in addition we could add
-- annotations of arbitrary types

-- | Term schema
data Schema b s c
  = CRec      [(Label,b (Schema b s c))]
  | CTbl Type [(Term, b (Schema b s c))]
  | CStr s
  | CPar c
--deriving Show -- doesn't work

instance Show s => Show (Schema b s c) where
  showsPrec :: SeqId -> Schema b s c -> FilePath -> FilePath
showsPrec SeqId
_ Schema b s c
sch =
      case Schema b s c
sch of
        CRec [(Label, b (Schema b s c))]
r   -> FilePath -> FilePath -> FilePath
showString FilePath
"CRec " (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Label] -> FilePath -> FilePath
forall a. Show a => a -> FilePath -> FilePath
shows (((Label, b (Schema b s c)) -> Label)
-> [(Label, b (Schema b s c))] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map (Label, b (Schema b s c)) -> Label
forall a b. (a, b) -> a
fst [(Label, b (Schema b s c))]
r)
        CTbl Type
t [(Type, b (Schema b s c))]
_ -> FilePath -> FilePath -> FilePath
showString FilePath
"CTbl " (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeqId -> Type -> FilePath -> FilePath
forall a. Show a => SeqId -> a -> FilePath -> FilePath
showsPrec SeqId
10 Type
t (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
" _"
        CStr s
s   -> FilePath -> FilePath -> FilePath
showString FilePath
"CStr " (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeqId -> s -> FilePath -> FilePath
forall a. Show a => SeqId -> a -> FilePath -> FilePath
showsPrec SeqId
10 s
s
        CPar c
c   -> FilePath -> FilePath -> FilePath
showString FilePath
"CPar{}"

-- | Path into a term or term schema
data Path
  = CProj Label Path
  | CSel  Term  Path
  | CNil
  deriving (Path -> Path -> Bool
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c== :: Path -> Path -> Bool
Eq,SeqId -> Path -> FilePath -> FilePath
[Path] -> FilePath -> FilePath
Path -> FilePath
(SeqId -> Path -> FilePath -> FilePath)
-> (Path -> FilePath)
-> ([Path] -> FilePath -> FilePath)
-> Show Path
forall a.
(SeqId -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Path] -> FilePath -> FilePath
$cshowList :: [Path] -> FilePath -> FilePath
show :: Path -> FilePath
$cshow :: Path -> FilePath
showsPrec :: SeqId -> Path -> FilePath -> FilePath
$cshowsPrec :: SeqId -> Path -> FilePath -> FilePath
Show)

-- | The ProtoFCat represents a linearization type as term schema.
-- The annotations are as follows: the strings are annotated with
-- their index in the PMCFG tuple, the parameters are annotated
-- with their value both as term and as index.
data ProtoFCat  = PFCat Ident Int (Schema Identity Int (Int,[(Term,Int)]))
type Env        = (ProtoFCat, [ProtoFCat])

protoFCat :: SourceGrammar -> Cat -> Type -> ProtoFCat
protoFCat :: Grammar -> Cat -> Type -> ProtoFCat
protoFCat Grammar
gr Cat
cat Type
lincat =
  case Grammar
-> Type
-> ((SeqId, SeqId), Schema Identity SeqId (SeqId, [(Type, SeqId)]))
forall s b.
(Num s, Num b, Enum b) =>
Grammar
-> Type -> ((s, SeqId), Schema Identity s (SeqId, [(Type, b)]))
computeCatRange Grammar
gr Type
lincat of
    ((SeqId
_,SeqId
f),Schema Identity SeqId (SeqId, [(Type, SeqId)])
schema) -> Ident
-> SeqId
-> Schema Identity SeqId (SeqId, [(Type, SeqId)])
-> ProtoFCat
PFCat (Cat -> Ident
forall a b. (a, b) -> b
snd Cat
cat) SeqId
f Schema Identity SeqId (SeqId, [(Type, SeqId)])
schema

getFIds :: ProtoFCat -> [FId]
getFIds :: ProtoFCat -> [SeqId]
getFIds (PFCat Ident
_ SeqId
_ Schema Identity SeqId (SeqId, [(Type, SeqId)])
schema) =
  [SeqId] -> [SeqId]
forall a. [a] -> [a]
reverse (BacktrackM () SeqId -> () -> [SeqId]
forall s a. BacktrackM s a -> s -> [a]
solutions (Schema Identity SeqId (SeqId, [(Type, SeqId)])
-> BacktrackM () SeqId
forall b s a s.
Num b =>
Schema Identity s (b, [(a, b)]) -> BacktrackM s b
variants Schema Identity SeqId (SeqId, [(Type, SeqId)])
schema) ())
  where
    variants :: Schema Identity s (b, [(a, b)]) -> BacktrackM s b
variants (CRec [(Label, Identity (Schema Identity s (b, [(a, b)])))]
rs)         = ([b] -> b) -> BacktrackM s [b] -> BacktrackM s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [b] -> b
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (BacktrackM s [b] -> BacktrackM s b)
-> BacktrackM s [b] -> BacktrackM s b
forall a b. (a -> b) -> a -> b
$ ((Label, Identity (Schema Identity s (b, [(a, b)])))
 -> BacktrackM s b)
-> [(Label, Identity (Schema Identity s (b, [(a, b)])))]
-> BacktrackM s [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Label
lbl,Identity Schema Identity s (b, [(a, b)])
t) -> Schema Identity s (b, [(a, b)]) -> BacktrackM s b
variants Schema Identity s (b, [(a, b)])
t) [(Label, Identity (Schema Identity s (b, [(a, b)])))]
rs
    variants (CTbl Type
_ [(Type, Identity (Schema Identity s (b, [(a, b)])))]
cs)       = ([b] -> b) -> BacktrackM s [b] -> BacktrackM s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [b] -> b
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (BacktrackM s [b] -> BacktrackM s b)
-> BacktrackM s [b] -> BacktrackM s b
forall a b. (a -> b) -> a -> b
$ ((Type, Identity (Schema Identity s (b, [(a, b)])))
 -> BacktrackM s b)
-> [(Type, Identity (Schema Identity s (b, [(a, b)])))]
-> BacktrackM s [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Type
trm,Identity Schema Identity s (b, [(a, b)])
t) -> Schema Identity s (b, [(a, b)]) -> BacktrackM s b
variants Schema Identity s (b, [(a, b)])
t) [(Type, Identity (Schema Identity s (b, [(a, b)])))]
cs
    variants (CStr s
_)          = b -> BacktrackM s b
forall (m :: * -> *) a. Monad m => a -> m a
return b
0
    variants (CPar (b
m,[(a, b)]
values)) = do (a
value,b
index) <- [(a, b)] -> BacktrackM s (a, b)
forall a s. [a] -> BacktrackM s a
member [(a, b)]
values
                                    b -> BacktrackM s b
forall (m :: * -> *) a. Monad m => a -> m a
return (b
mb -> b -> b
forall a. Num a => a -> a -> a
*b
index)

catFactor :: ProtoFCat -> Int
catFactor :: ProtoFCat -> SeqId
catFactor (PFCat Ident
_ SeqId
f Schema Identity SeqId (SeqId, [(Type, SeqId)])
_) = SeqId
f

computeCatRange :: Grammar
-> Type -> ((s, SeqId), Schema Identity s (SeqId, [(Type, b)]))
computeCatRange Grammar
gr Type
lincat = (s, SeqId)
-> Type -> ((s, SeqId), Schema Identity s (SeqId, [(Type, b)]))
forall s b.
(Num s, Num b, Enum b) =>
(s, SeqId)
-> Type -> ((s, SeqId), Schema Identity s (SeqId, [(Type, b)]))
compute (s
0,SeqId
1) Type
lincat
  where
    compute :: (s, SeqId)
-> Type -> ((s, SeqId), Schema Identity s (SeqId, [(Type, b)]))
compute (s, SeqId)
st (RecType  [Labelling]
rs) = let ((s, SeqId)
st',[(Label, Identity (Schema Identity s (SeqId, [(Type, b)])))]
rs') = ((s, SeqId)
 -> Labelling
 -> ((s, SeqId),
     (Label, Identity (Schema Identity s (SeqId, [(Type, b)])))))
-> (s, SeqId)
-> [Labelling]
-> ((s, SeqId),
    [(Label, Identity (Schema Identity s (SeqId, [(Type, b)])))])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
List.mapAccumL (\(s, SeqId)
st (Label
lbl,Type
t) -> case Label
lbl of
                                                                                LVar SeqId
_ -> let ((s, SeqId)
st',Schema Identity s (SeqId, [(Type, b)])
t') = (s, SeqId)
-> Type -> ((s, SeqId), Schema Identity s (SeqId, [(Type, b)]))
compute (s, SeqId)
st Type
t
                                                                                          in ((s, SeqId)
st ,(Label
lbl,Schema Identity s (SeqId, [(Type, b)])
-> Identity (Schema Identity s (SeqId, [(Type, b)]))
forall a. a -> Identity a
Identity Schema Identity s (SeqId, [(Type, b)])
t'))
                                                                                Label
_      -> let ((s, SeqId)
st',Schema Identity s (SeqId, [(Type, b)])
t') = (s, SeqId)
-> Type -> ((s, SeqId), Schema Identity s (SeqId, [(Type, b)]))
compute (s, SeqId)
st Type
t
                                                                                          in ((s, SeqId)
st',(Label
lbl,Schema Identity s (SeqId, [(Type, b)])
-> Identity (Schema Identity s (SeqId, [(Type, b)]))
forall a. a -> Identity a
Identity Schema Identity s (SeqId, [(Type, b)])
t'))) (s, SeqId)
st [Labelling]
rs
                               in ((s, SeqId)
st',[(Label, Identity (Schema Identity s (SeqId, [(Type, b)])))]
-> Schema Identity s (SeqId, [(Type, b)])
forall (b :: * -> *) s c.
[(Label, b (Schema b s c))] -> Schema b s c
CRec [(Label, Identity (Schema Identity s (SeqId, [(Type, b)])))]
rs')
    compute (s, SeqId)
st (Table Type
pt Type
vt) = let vs :: [Type]
vs        = (FilePath -> [Type]) -> ([Type] -> [Type]) -> Err [Type] -> [Type]
forall b a. (FilePath -> b) -> (a -> b) -> Err a -> b
err FilePath -> [Type]
forall a a. Pretty a => a -> a
bug [Type] -> [Type]
forall a. a -> a
id (Grammar -> Type -> Err [Type]
forall (m :: * -> *). ErrorMonad m => Grammar -> Type -> m [Type]
allParamValues Grammar
gr Type
pt)
                                   ((s, SeqId)
st',[(Type, Identity (Schema Identity s (SeqId, [(Type, b)])))]
cs') = ((s, SeqId)
 -> Type
 -> ((s, SeqId),
     (Type, Identity (Schema Identity s (SeqId, [(Type, b)])))))
-> (s, SeqId)
-> [Type]
-> ((s, SeqId),
    [(Type, Identity (Schema Identity s (SeqId, [(Type, b)])))])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
List.mapAccumL (\(s, SeqId)
st Type
v       -> let ((s, SeqId)
st',Schema Identity s (SeqId, [(Type, b)])
vt') = (s, SeqId)
-> Type -> ((s, SeqId), Schema Identity s (SeqId, [(Type, b)]))
compute (s, SeqId)
st Type
vt
                                                                              in ((s, SeqId)
st',(Type
v,Schema Identity s (SeqId, [(Type, b)])
-> Identity (Schema Identity s (SeqId, [(Type, b)]))
forall a. a -> Identity a
Identity Schema Identity s (SeqId, [(Type, b)])
vt'))) (s, SeqId)
st [Type]
vs
                               in ((s, SeqId)
st',Type
-> [(Type, Identity (Schema Identity s (SeqId, [(Type, b)])))]
-> Schema Identity s (SeqId, [(Type, b)])
forall (b :: * -> *) s c.
Type -> [(Type, b (Schema b s c))] -> Schema b s c
CTbl Type
pt [(Type, Identity (Schema Identity s (SeqId, [(Type, b)])))]
cs')
    compute (s, SeqId)
st (Sort Ident
s)
                   | Ident
s Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cStr = let (s
index,SeqId
m) = (s, SeqId)
st
                                 in ((s
indexs -> s -> s
forall a. Num a => a -> a -> a
+s
1,SeqId
m),s -> Schema Identity s (SeqId, [(Type, b)])
forall (b :: * -> *) s c. s -> Schema b s c
CStr s
index)
    compute (s, SeqId)
st Type
t               = let vs :: [Type]
vs = (FilePath -> [Type]) -> ([Type] -> [Type]) -> Err [Type] -> [Type]
forall b a. (FilePath -> b) -> (a -> b) -> Err a -> b
err FilePath -> [Type]
forall a a. Pretty a => a -> a
bug [Type] -> [Type]
forall a. a -> a
id (Grammar -> Type -> Err [Type]
forall (m :: * -> *). ErrorMonad m => Grammar -> Type -> m [Type]
allParamValues Grammar
gr Type
t)
                                     (s
index,SeqId
m) = (s, SeqId)
st
                                 in ((s
index,SeqId
mSeqId -> SeqId -> SeqId
forall a. Num a => a -> a -> a
*[Type] -> SeqId
forall (t :: * -> *) a. Foldable t => t a -> SeqId
length [Type]
vs),(SeqId, [(Type, b)]) -> Schema Identity s (SeqId, [(Type, b)])
forall (b :: * -> *) s c. c -> Schema b s c
CPar (SeqId
m,[Type] -> [b] -> [(Type, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
vs [b
0..]))

ppPath :: Path -> Doc
ppPath (CProj Label
lbl Path
path) = Label
lbl Label -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Path -> Doc
ppPath Path
path
ppPath (CSel  Type
trm Path
path) = Integer -> Type -> Doc
ppU Integer
5 Type
trm   Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Path -> Doc
ppPath Path
path
ppPath Path
CNil             = Doc
empty

reversePath :: Path -> Path
reversePath Path
path = Path -> Path -> Path
rev Path
CNil Path
path
  where
    rev :: Path -> Path -> Path
rev Path
path0 Path
CNil             = Path
path0
    rev Path
path0 (CProj Label
lbl Path
path) = Path -> Path -> Path
rev (Label -> Path -> Path
CProj Label
lbl Path
path0) Path
path
    rev Path
path0 (CSel  Type
trm Path
path) = Path -> Path -> Path
rev (Type -> Path -> Path
CSel  Type
trm Path
path0) Path
path


----------------------------------------------------------------------
-- term conversion

type Value a = Schema Branch a Term

convertTerm :: Options -> Path -> Type -> Term -> CnvMonad (Value [Symbol])
convertTerm :: Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
sel Type
ctype (Vr Ident
x)       = Options -> Type -> SeqId -> Path -> CnvMonad (Value [Symbol])
convertArg Options
opts Type
ctype (Ident -> SeqId
getVarIndex Ident
x) (Path -> Path
reversePath Path
sel)
convertTerm Options
opts Path
sel Type
ctype (Abs BindType
_ Ident
_ Type
t)  = Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
sel Type
ctype Type
t                -- there are only top-level abstractions and we ignore them !!!
convertTerm Options
opts Path
sel Type
ctype (R [Assign]
record)   = Options -> Path -> Type -> [Assign] -> CnvMonad (Value [Symbol])
convertRec Options
opts Path
sel Type
ctype [Assign]
record
convertTerm Options
opts Path
sel Type
ctype (P Type
term Label
l)   = Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts (Label -> Path -> Path
CProj Label
l Path
sel) Type
ctype Type
term
convertTerm Options
opts Path
sel Type
ctype (V Type
pt [Type]
ts)    = Options
-> Path -> Type -> Type -> [Type] -> CnvMonad (Value [Symbol])
convertTbl Options
opts Path
sel Type
ctype Type
pt [Type]
ts
convertTerm Options
opts Path
sel Type
ctype (S Type
term Type
p)   = do Type
v <- Path -> Type -> CnvMonad Type
evalTerm Path
CNil Type
p
                                             Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts (Type -> Path -> Path
CSel Type
v Path
sel) Type
ctype Type
term
convertTerm Options
opts Path
sel Type
ctype (FV [Type]
vars)    = do Type
term <- [Type] -> CnvMonad Type
forall a. [a] -> CnvMonad a
variants [Type]
vars
                                             Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
sel Type
ctype Type
term
convertTerm Options
opts Path
sel Type
ctype (C Type
t1 Type
t2)    = do Value [Symbol]
v1 <- Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
sel Type
ctype Type
t1
                                             Value [Symbol]
v2 <- Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
sel Type
ctype Type
t2
                                             Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol] -> Value [Symbol]
forall (b :: * -> *) s c. s -> Schema b s c
CStr ([[Symbol]] -> [Symbol]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Symbol]
s | CStr [Symbol]
s <- [Value [Symbol]
v1,Value [Symbol]
v2]]))
convertTerm Options
opts Path
sel Type
ctype (K FilePath
t)        = Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol] -> Value [Symbol]
forall (b :: * -> *) s c. s -> Schema b s c
CStr [FilePath -> Symbol
SymKS FilePath
t])
convertTerm Options
opts Path
sel Type
ctype Type
Empty        = Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol] -> Value [Symbol]
forall (b :: * -> *) s c. s -> Schema b s c
CStr [])
convertTerm Options
opts Path
sel Type
ctype (Alts Type
s [(Type, Type)]
alts)= do CStr [Symbol]
s <- Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
CNil Type
ctype Type
s
                                             [([Symbol], [FilePath])]
alts <- [(Type, Type)]
-> ((Type, Type) -> CnvMonad ([Symbol], [FilePath]))
-> CnvMonad [([Symbol], [FilePath])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Type, Type)]
alts (((Type, Type) -> CnvMonad ([Symbol], [FilePath]))
 -> CnvMonad [([Symbol], [FilePath])])
-> ((Type, Type) -> CnvMonad ([Symbol], [FilePath]))
-> CnvMonad [([Symbol], [FilePath])]
forall a b. (a -> b) -> a -> b
$ \(Type
u,Type
alt) -> do
                                                            CStr [Symbol]
u <- Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
CNil Type
ctype Type
u
                                                            Strs [Type]
ps <- Type -> CnvMonad Type
forall (f :: * -> *). MonadFail f => Type -> f Type
unPatt Type
alt
                                                            [Value [Symbol]]
ps     <- (Type -> CnvMonad (Value [Symbol]))
-> [Type] -> CnvMonad [Value [Symbol]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
CNil Type
ctype) [Type]
ps
                                                            ([Symbol], [FilePath]) -> CnvMonad ([Symbol], [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol]
u,(Value [Symbol] -> FilePath) -> [Value [Symbol]] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Value [Symbol] -> FilePath
forall (b :: * -> *) c. Schema b [Symbol] c -> FilePath
unSym [Value [Symbol]]
ps)
                                             Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol] -> Value [Symbol]
forall (b :: * -> *) s c. s -> Schema b s c
CStr [[Symbol] -> [([Symbol], [FilePath])] -> Symbol
SymKP [Symbol]
s [([Symbol], [FilePath])]
alts])
  where
    unSym :: Schema b [Symbol] c -> FilePath
unSym (CStr [])        = FilePath
""
    unSym (CStr [SymKS FilePath
t]) = FilePath
t
    unSym Schema b [Symbol] c
_                = Doc -> FilePath
forall a a. Pretty a => a -> a
ppbug (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> SeqId -> Type -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> SeqId -> a2 -> Doc
hang (FilePath
"invalid prefix in pre expression:") SeqId
4 (Type -> [(Type, Type)] -> Type
Alts Type
s [(Type, Type)]
alts)

    unPatt :: Type -> f Type
unPatt (EPatt Patt
p) = ([Type] -> Type) -> f [Type] -> f Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Type] -> Type
Strs (Patt -> f [Type]
forall (m :: * -> *). MonadFail m => Patt -> m [Type]
getPatts Patt
p)
    unPatt Type
u         = Type -> f Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
u

    getPatts :: Patt -> m [Type]
getPatts Patt
p = case Patt
p of
      PAlt Patt
a Patt
b  -> ([Type] -> [Type] -> [Type]) -> m [Type] -> m [Type] -> m [Type]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
(++) (Patt -> m [Type]
getPatts Patt
a) (Patt -> m [Type]
getPatts Patt
b)
      PString FilePath
s -> [Type] -> m [Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath -> Type
K FilePath
s]
      PSeq Patt
a Patt
b  -> do
        [Type]
as <- Patt -> m [Type]
getPatts Patt
a
        [Type]
bs <- Patt -> m [Type]
getPatts Patt
b
        [Type] -> m [Type]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath -> Type
K (FilePath
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
t) | K FilePath
s <- [Type]
as, K FilePath
t <- [Type]
bs]
      Patt
_ -> FilePath -> m [Type]
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (Doc -> FilePath
forall a. Pretty a => a -> FilePath
render (FilePath
"not valid pattern in pre expression" FilePath -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> TermPrintQual -> Integer -> Patt -> Doc
forall a. (Num a, Ord a) => TermPrintQual -> a -> Patt -> Doc
ppPatt TermPrintQual
Unqualified Integer
0 Patt
p))

convertTerm Options
opts Path
sel Type
ctype (Q (ModuleName
m,Ident
f))
  | ModuleName
m ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
cPredef Bool -> Bool -> Bool
&&
    Ident
f Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cBIND                          = Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol] -> Value [Symbol]
forall (b :: * -> *) s c. s -> Schema b s c
CStr [Symbol
SymBIND])
  | ModuleName
m ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
cPredef Bool -> Bool -> Bool
&&
    Ident
f Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cSOFT_BIND                     = Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol] -> Value [Symbol]
forall (b :: * -> *) s c. s -> Schema b s c
CStr [Symbol
SymSOFT_BIND])
  | ModuleName
m ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
cPredef Bool -> Bool -> Bool
&&
    Ident
f Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cSOFT_SPACE                    = Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol] -> Value [Symbol]
forall (b :: * -> *) s c. s -> Schema b s c
CStr [Symbol
SymSOFT_SPACE])
  | ModuleName
m ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
cPredef Bool -> Bool -> Bool
&&
    Ident
f Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cCAPIT                         = Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol] -> Value [Symbol]
forall (b :: * -> *) s c. s -> Schema b s c
CStr [Symbol
SymCAPIT])
  | ModuleName
m ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
cPredef Bool -> Bool -> Bool
&&
    Ident
f Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cALL_CAPIT                     = Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol] -> Value [Symbol]
forall (b :: * -> *) s c. s -> Schema b s c
CStr [Symbol
SymALL_CAPIT])
  | ModuleName
m ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
cPredef Bool -> Bool -> Bool
&&
    Ident
f Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
== Ident
cNonExist                      = Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol] -> Value [Symbol]
forall (b :: * -> *) s c. s -> Schema b s c
CStr [Symbol
SymNE])
{-
convertTerm opts sel@(CProj l _) ctype (ExtR t1 t2@(R rs2))
                    | l `elem` map fst rs2 = convertTerm opts sel ctype t2
                    | otherwise            = convertTerm opts sel ctype t1

convertTerm opts sel@(CProj l _) ctype (ExtR t1@(R rs1) t2)
                    | l `elem` map fst rs1 = convertTerm opts sel ctype t1
                    | otherwise            = convertTerm opts sel ctype t2
-}
convertTerm Options
opts Path
CNil Type
ctype Type
t           = do Type
v <- Path -> Type -> CnvMonad Type
evalTerm Path
CNil Type
t
                                             Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Value [Symbol]
forall (b :: * -> *) s c. c -> Schema b s c
CPar Type
v)
convertTerm Options
_    Path
sel  Type
_     Type
t           = Doc -> CnvMonad (Value [Symbol])
forall a a. Pretty a => a -> a
ppbug (FilePath
"convertTerm" FilePath -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> [Doc] -> Doc
forall a. Pretty a => [a] -> Doc
sep [FilePath -> Doc
forall a. Pretty a => a -> Doc
parens (Path -> FilePath
forall a. Show a => a -> FilePath
show Path
sel),Integer -> Type -> Doc
ppU Integer
10 Type
t])

convertArg :: Options -> Term -> Int -> Path -> CnvMonad (Value [Symbol])
convertArg :: Options -> Type -> SeqId -> Path -> CnvMonad (Value [Symbol])
convertArg Options
opts (RecType [Labelling]
rs)  SeqId
nr Path
path =
  [(Label, CnvMonad (Value [Symbol]))] -> CnvMonad (Value [Symbol])
forall s c.
[(Label, CnvMonad (Schema Branch s c))]
-> CnvMonad (Schema Branch s c)
mkRecord ((Labelling -> (Label, CnvMonad (Value [Symbol])))
-> [Labelling] -> [(Label, CnvMonad (Value [Symbol]))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Label
lbl,Type
ctype) -> (Label
lbl,Options -> Type -> SeqId -> Path -> CnvMonad (Value [Symbol])
convertArg Options
opts Type
ctype SeqId
nr (Label -> Path -> Path
CProj Label
lbl Path
path))) [Labelling]
rs)
convertArg Options
opts (Table Type
pt Type
vt) SeqId
nr Path
path = do
  [Type]
vs <- Type -> CnvMonad [Type]
getAllParamValues Type
pt
  Type
-> [(Type, CnvMonad (Value [Symbol]))] -> CnvMonad (Value [Symbol])
forall s c.
Type
-> [(Type, CnvMonad (Schema Branch s c))]
-> CnvMonad (Schema Branch s c)
mkTable Type
pt ((Type -> (Type, CnvMonad (Value [Symbol])))
-> [Type] -> [(Type, CnvMonad (Value [Symbol]))]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
v -> (Type
v,Options -> Type -> SeqId -> Path -> CnvMonad (Value [Symbol])
convertArg Options
opts Type
vt SeqId
nr (Type -> Path -> Path
CSel Type
v Path
path))) [Type]
vs)
convertArg Options
opts (Sort Ident
_)      SeqId
nr Path
path = do
  ([ProtoFCat]
args,[Symbol]
_) <- CnvMonad ([ProtoFCat], [Symbol])
forall s (m :: * -> *). MonadState s m => m s
get
  let PFCat Ident
cat SeqId
_ Schema Identity SeqId (SeqId, [(Type, SeqId)])
schema = [ProtoFCat]
args [ProtoFCat] -> SeqId -> ProtoFCat
forall a. [a] -> SeqId -> a
!! SeqId
nr
      l :: SeqId
l = Path -> Schema Identity SeqId (SeqId, [(Type, SeqId)]) -> SeqId
forall p c. Path -> Schema Identity p c -> p
index (Path -> Path
reversePath Path
path) Schema Identity SeqId (SeqId, [(Type, SeqId)])
schema
      sym :: Symbol
sym | CProj (LVar SeqId
i) Path
CNil <- Path
path = SeqId -> SeqId -> Symbol
SymVar SeqId
nr SeqId
i
          | Options -> Ident -> Bool
isLiteralCat Options
opts Ident
cat       = SeqId -> SeqId -> Symbol
SymLit SeqId
nr SeqId
l
          | Bool
otherwise                   = SeqId -> SeqId -> Symbol
SymCat SeqId
nr SeqId
l
  Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Symbol] -> Value [Symbol]
forall (b :: * -> *) s c. s -> Schema b s c
CStr [Symbol
sym])
  where
    index :: Path -> Schema Identity p c -> p
index (CProj Label
lbl Path
path) (CRec   [(Label, Identity (Schema Identity p c))]
rs) = case Label
-> [(Label, Identity (Schema Identity p c))]
-> Maybe (Identity (Schema Identity p c))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Label
lbl [(Label, Identity (Schema Identity p c))]
rs of
                                           Just (Identity Schema Identity p c
t) -> Path -> Schema Identity p c -> p
index Path
path Schema Identity p c
t
    index (CSel  Type
trm Path
path) (CTbl Type
_ [(Type, Identity (Schema Identity p c))]
rs) = case Type
-> [(Type, Identity (Schema Identity p c))]
-> Maybe (Identity (Schema Identity p c))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Type
trm [(Type, Identity (Schema Identity p c))]
rs of
                                           Just (Identity Schema Identity p c
t) -> Path -> Schema Identity p c -> p
index Path
path Schema Identity p c
t
    index Path
CNil             (CStr p
idx)  = p
idx
convertArg Options
opts Type
ty SeqId
nr Path
path              = do
  Type
value <- SeqId -> Path -> CnvMonad Type
choices SeqId
nr (Path -> Path
reversePath Path
path)
  Value [Symbol] -> CnvMonad (Value [Symbol])
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Value [Symbol]
forall (b :: * -> *) s c. c -> Schema b s c
CPar Type
value)

convertRec :: Options -> Path -> Type -> [Assign] -> CnvMonad (Value [Symbol])
convertRec Options
opts Path
CNil (RecType [Labelling]
rs) [Assign]
record =
    [(Label, CnvMonad (Value [Symbol]))] -> CnvMonad (Value [Symbol])
forall s c.
[(Label, CnvMonad (Schema Branch s c))]
-> CnvMonad (Schema Branch s c)
mkRecord [(Label
lbl,Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
CNil Type
ctype (Label -> Type
proj Label
lbl))|(Label
lbl,Type
ctype)<-[Labelling]
rs]
  where proj :: Label -> Type
proj Label
lbl = if Label -> Bool
isLockLabel Label
lbl then [Assign] -> Type
R [] else Label -> [Assign] -> Type
projectRec Label
lbl [Assign]
record
convertRec Options
opts (CProj Label
lbl Path
path) Type
ctype [Assign]
record =
  Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
path Type
ctype (Label -> [Assign] -> Type
projectRec Label
lbl [Assign]
record)
convertRec Options
opts Path
_ Type
ctype [Assign]
_ = FilePath -> CnvMonad (Value [Symbol])
forall a a. Pretty a => a -> a
bug (FilePath
"convertRec: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Type -> FilePath
forall a. Show a => a -> FilePath
show Type
ctype)

convertTbl :: Options
-> Path -> Type -> Type -> [Type] -> CnvMonad (Value [Symbol])
convertTbl Options
opts Path
CNil (Table Type
_ Type
vt) Type
pt [Type]
ts = do
  [Type]
vs <- Type -> CnvMonad [Type]
getAllParamValues Type
pt
  Type
-> [(Type, CnvMonad (Value [Symbol]))] -> CnvMonad (Value [Symbol])
forall s c.
Type
-> [(Type, CnvMonad (Schema Branch s c))]
-> CnvMonad (Schema Branch s c)
mkTable Type
pt ((Type -> Type -> (Type, CnvMonad (Value [Symbol])))
-> [Type] -> [Type] -> [(Type, CnvMonad (Value [Symbol]))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Type
v Type
t -> (Type
v,Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
CNil Type
vt Type
t)) [Type]
vs [Type]
ts)
convertTbl Options
opts (CSel Type
v Path
sub_sel) Type
ctype Type
pt [Type]
ts = do
  [Type]
vs <- Type -> CnvMonad [Type]
getAllParamValues Type
pt
  case Type -> [(Type, Type)] -> Maybe Type
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Type
v ([Type] -> [Type] -> [(Type, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
vs [Type]
ts) of
    Just Type
t  -> Options -> Path -> Type -> Type -> CnvMonad (Value [Symbol])
convertTerm Options
opts Path
sub_sel Type
ctype Type
t
    Maybe Type
Nothing -> Doc -> CnvMonad (Value [Symbol])
forall a a. Pretty a => a -> a
ppbug ( FilePath
"convertTbl:" FilePath -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> (FilePath
"missing value" FilePath -> Type -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Type
v Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
                                          FilePath
"among" FilePath -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> [Type] -> Doc
forall a. Pretty a => [a] -> Doc
vcat [Type]
vs))
convertTbl Options
opts Path
_ Type
ctype Type
_ [Type]
_ = FilePath -> CnvMonad (Value [Symbol])
forall a a. Pretty a => a -> a
bug (FilePath
"convertTbl: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Type -> FilePath
forall a. Show a => a -> FilePath
show Type
ctype)


goB :: Branch (Value SeqId) -> Path -> [SeqId] -> BacktrackM Env [SeqId]
goB :: Branch (Value SeqId)
-> Path -> [SeqId] -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
goB (Case SeqId
nr Path
path [(Type, Branch (Value SeqId))]
bs) Path
rpath [SeqId]
ss = do (Type
value,Branch (Value SeqId)
b) <- [(Type, Branch (Value SeqId))]
-> BacktrackM (ProtoFCat, [ProtoFCat]) (Type, Branch (Value SeqId))
forall a s. [a] -> BacktrackM s a
member [(Type, Branch (Value SeqId))]
bs
                                    SeqId -> Path -> Type -> BacktrackM (ProtoFCat, [ProtoFCat]) ()
restrictArg SeqId
nr Path
path Type
value
                                    Branch (Value SeqId)
-> Path -> [SeqId] -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
goB Branch (Value SeqId)
b Path
rpath [SeqId]
ss
goB (Variant [Branch (Value SeqId)]
bs)      Path
rpath [SeqId]
ss = do Branch (Value SeqId)
b <- [Branch (Value SeqId)]
-> BacktrackM (ProtoFCat, [ProtoFCat]) (Branch (Value SeqId))
forall a s. [a] -> BacktrackM s a
member [Branch (Value SeqId)]
bs
                                    Branch (Value SeqId)
-> Path -> [SeqId] -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
goB Branch (Value SeqId)
b Path
rpath [SeqId]
ss
goB (Return  Value SeqId
v)       Path
rpath [SeqId]
ss = Value SeqId
-> Path -> [SeqId] -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
goV Value SeqId
v Path
rpath [SeqId]
ss

goV :: Value SeqId -> Path -> [SeqId] -> BacktrackM Env [SeqId]
goV :: Value SeqId
-> Path -> [SeqId] -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
goV (CRec [(Label, Branch (Value SeqId))]
xs)    Path
rpath [SeqId]
ss = ([SeqId]
 -> (Label, Branch (Value SeqId))
 -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId])
-> [SeqId]
-> [(Label, Branch (Value SeqId))]
-> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\[SeqId]
ss (Label
lbl,Branch (Value SeqId)
b) -> Branch (Value SeqId)
-> Path -> [SeqId] -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
goB Branch (Value SeqId)
b (Label -> Path -> Path
CProj Label
lbl Path
rpath) [SeqId]
ss) [SeqId]
ss ([(Label, Branch (Value SeqId))] -> [(Label, Branch (Value SeqId))]
forall a. [a] -> [a]
reverse [(Label, Branch (Value SeqId))]
xs)
goV (CTbl Type
_ [(Type, Branch (Value SeqId))]
xs)  Path
rpath [SeqId]
ss = ([SeqId]
 -> (Type, Branch (Value SeqId))
 -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId])
-> [SeqId]
-> [(Type, Branch (Value SeqId))]
-> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\[SeqId]
ss (Type
trm,Branch (Value SeqId)
b) -> Branch (Value SeqId)
-> Path -> [SeqId] -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
goB Branch (Value SeqId)
b (Type -> Path -> Path
CSel  Type
trm Path
rpath) [SeqId]
ss) [SeqId]
ss ([(Type, Branch (Value SeqId))] -> [(Type, Branch (Value SeqId))]
forall a. [a] -> [a]
reverse [(Type, Branch (Value SeqId))]
xs)
goV (CStr SeqId
seqid) Path
rpath [SeqId]
ss = [SeqId] -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
forall (m :: * -> *) a. Monad m => a -> m a
return (SeqId
seqid SeqId -> [SeqId] -> [SeqId]
forall a. a -> [a] -> [a]
: [SeqId]
ss)
goV (CPar Type
t)     Path
rpath [SeqId]
ss = Path -> Type -> BacktrackM (ProtoFCat, [ProtoFCat]) ()
restrictHead (Path -> Path
reversePath Path
rpath) Type
t BacktrackM (ProtoFCat, [ProtoFCat]) ()
-> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
-> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [SeqId] -> BacktrackM (ProtoFCat, [ProtoFCat]) [SeqId]
forall (m :: * -> *) a. Monad m => a -> m a
return [SeqId]
ss


----------------------------------------------------------------------
-- SeqSet

type SeqSet   = Map.Map Sequence SeqId

addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
addSequencesB :: SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
addSequencesB SeqSet
seqs (Case SeqId
nr Path
path [(Type, Branch (Value [Symbol]))]
bs) = let !(SeqSet
seqs1,[(Type, Branch (Value SeqId))]
bs1) = (SeqSet
 -> (Type, Branch (Value [Symbol]))
 -> (SeqSet, (Type, Branch (Value SeqId))))
-> SeqSet
-> [(Type, Branch (Value [Symbol]))]
-> (SeqSet, [(Type, Branch (Value SeqId))])
forall a a a. (a -> a -> (a, a)) -> a -> [a] -> (a, [a])
mapAccumL' (\SeqSet
seqs (Type
trm,Branch (Value [Symbol])
b) -> let !(SeqSet
seqs',Branch (Value SeqId)
b') = SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
addSequencesB SeqSet
seqs Branch (Value [Symbol])
b
                                                                                       in (SeqSet
seqs',(Type
trm,Branch (Value SeqId)
b'))) SeqSet
seqs [(Type, Branch (Value [Symbol]))]
bs
                                       in (SeqSet
seqs1,SeqId
-> Path -> [(Type, Branch (Value SeqId))] -> Branch (Value SeqId)
forall a. SeqId -> Path -> [(Type, Branch a)] -> Branch a
Case SeqId
nr Path
path [(Type, Branch (Value SeqId))]
bs1)
addSequencesB SeqSet
seqs (Variant [Branch (Value [Symbol])]
bs)      = let !(SeqSet
seqs1,[Branch (Value SeqId)]
bs1) = (SeqSet
 -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId)))
-> SeqSet
-> [Branch (Value [Symbol])]
-> (SeqSet, [Branch (Value SeqId)])
forall a a a. (a -> a -> (a, a)) -> a -> [a] -> (a, [a])
mapAccumL' SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
addSequencesB SeqSet
seqs [Branch (Value [Symbol])]
bs
                                       in (SeqSet
seqs1,[Branch (Value SeqId)] -> Branch (Value SeqId)
forall a. [Branch a] -> Branch a
Variant [Branch (Value SeqId)]
bs1)
addSequencesB SeqSet
seqs (Return  Value [Symbol]
v)       = let !(SeqSet
seqs1,Value SeqId
v1) = SeqSet -> Value [Symbol] -> (SeqSet, Value SeqId)
addSequencesV SeqSet
seqs Value [Symbol]
v
                                       in (SeqSet
seqs1,Value SeqId -> Branch (Value SeqId)
forall a. a -> Branch a
Return Value SeqId
v1)

addSequencesV :: SeqSet -> Value [Symbol] -> (SeqSet, Value SeqId)
addSequencesV :: SeqSet -> Value [Symbol] -> (SeqSet, Value SeqId)
addSequencesV SeqSet
seqs (CRec [(Label, Branch (Value [Symbol]))]
vs)  = let !(SeqSet
seqs1,[(Label, Branch (Value SeqId))]
vs1) = (SeqSet
 -> (Label, Branch (Value [Symbol]))
 -> (SeqSet, (Label, Branch (Value SeqId))))
-> SeqSet
-> [(Label, Branch (Value [Symbol]))]
-> (SeqSet, [(Label, Branch (Value SeqId))])
forall a a a. (a -> a -> (a, a)) -> a -> [a] -> (a, [a])
mapAccumL' (\SeqSet
seqs (Label
lbl,Branch (Value [Symbol])
b) -> let !(SeqSet
seqs',Branch (Value SeqId)
b') = SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
addSequencesB SeqSet
seqs Branch (Value [Symbol])
b
                                                                                in (SeqSet
seqs',(Label
lbl,Branch (Value SeqId)
b'))) SeqSet
seqs [(Label, Branch (Value [Symbol]))]
vs
                                in (SeqSet
seqs1,[(Label, Branch (Value SeqId))] -> Value SeqId
forall (b :: * -> *) s c.
[(Label, b (Schema b s c))] -> Schema b s c
CRec [(Label, Branch (Value SeqId))]
vs1)
addSequencesV SeqSet
seqs (CTbl Type
pt [(Type, Branch (Value [Symbol]))]
vs)=let !(SeqSet
seqs1,[(Type, Branch (Value SeqId))]
vs1) = (SeqSet
 -> (Type, Branch (Value [Symbol]))
 -> (SeqSet, (Type, Branch (Value SeqId))))
-> SeqSet
-> [(Type, Branch (Value [Symbol]))]
-> (SeqSet, [(Type, Branch (Value SeqId))])
forall a a a. (a -> a -> (a, a)) -> a -> [a] -> (a, [a])
mapAccumL' (\SeqSet
seqs (Type
trm,Branch (Value [Symbol])
b) -> let !(SeqSet
seqs',Branch (Value SeqId)
b') = SeqSet -> Branch (Value [Symbol]) -> (SeqSet, Branch (Value SeqId))
addSequencesB SeqSet
seqs Branch (Value [Symbol])
b
                                                                                in (SeqSet
seqs',(Type
trm,Branch (Value SeqId)
b'))) SeqSet
seqs [(Type, Branch (Value [Symbol]))]
vs
                                in (SeqSet
seqs1,Type -> [(Type, Branch (Value SeqId))] -> Value SeqId
forall (b :: * -> *) s c.
Type -> [(Type, b (Schema b s c))] -> Schema b s c
CTbl Type
pt [(Type, Branch (Value SeqId))]
vs1)
addSequencesV SeqSet
seqs (CStr [Symbol]
lin) = let !(SeqSet
seqs1,SeqId
seqid) = SeqSet -> [Symbol] -> (SeqSet, SeqId)
addSequence SeqSet
seqs [Symbol]
lin
                                in (SeqSet
seqs1,SeqId -> Value SeqId
forall (b :: * -> *) s c. s -> Schema b s c
CStr SeqId
seqid)
addSequencesV SeqSet
seqs (CPar Type
i)   = (SeqSet
seqs,Type -> Value SeqId
forall (b :: * -> *) s c. c -> Schema b s c
CPar Type
i)

-- a strict version of Data.List.mapAccumL
mapAccumL' :: (a -> a -> (a, a)) -> a -> [a] -> (a, [a])
mapAccumL' a -> a -> (a, a)
f a
s []     = (a
s,[])
mapAccumL' a -> a -> (a, a)
f a
s (a
x:[a]
xs) = (a
s'',a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys)
                        where !(a
s', a
y ) = a -> a -> (a, a)
f a
s a
x
                              !(a
s'',[a]
ys) = (a -> a -> (a, a)) -> a -> [a] -> (a, [a])
mapAccumL' a -> a -> (a, a)
f a
s' [a]
xs

addSequence :: SeqSet -> [Symbol] -> (SeqSet,SeqId)
addSequence :: SeqSet -> [Symbol] -> (SeqSet, SeqId)
addSequence SeqSet
seqs [Symbol]
lst =
  case Sequence -> SeqSet -> Maybe SeqId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Sequence
seq SeqSet
seqs of
    Just SeqId
id -> (SeqSet
seqs,SeqId
id)
    Maybe SeqId
Nothing -> let !last_seq :: SeqId
last_seq = SeqSet -> SeqId
forall k a. Map k a -> SeqId
Map.size SeqSet
seqs
               in (Sequence -> SeqId -> SeqSet -> SeqSet
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Sequence
seq SeqId
last_seq SeqSet
seqs, SeqId
last_seq)
  where
    seq :: Sequence
seq = [Symbol] -> Sequence
forall (a :: * -> * -> *) e. IArray a e => [e] -> a SeqId e
mkArray [Symbol]
lst


------------------------------------------------------------
-- eval a term to ground terms

evalTerm :: Path -> Term -> CnvMonad Term
evalTerm :: Path -> Type -> CnvMonad Type
evalTerm Path
CNil (QC Cat
f)       = Type -> CnvMonad Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Cat -> Type
QC Cat
f)
evalTerm Path
CNil (App Type
x Type
y)    = do Type
x <- Path -> Type -> CnvMonad Type
evalTerm Path
CNil Type
x
                                Type
y <- Path -> Type -> CnvMonad Type
evalTerm Path
CNil Type
y
                                Type -> CnvMonad Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Type
App Type
x Type
y)
evalTerm Path
path (Vr Ident
x)       = SeqId -> Path -> CnvMonad Type
choices (Ident -> SeqId
getVarIndex Ident
x) Path
path
evalTerm Path
path (R [Assign]
rs)       =
    case Path
path of
      CProj Label
lbl Path
path -> Path -> Type -> CnvMonad Type
evalTerm Path
path (Label -> [Assign] -> Type
projectRec Label
lbl [Assign]
rs)
      Path
CNil           -> [Assign] -> Type
R ([Assign] -> Type) -> CnvMonad [Assign] -> CnvMonad Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Assign -> CnvMonad Assign) -> [Assign] -> CnvMonad [Assign]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Label
lbl,(Maybe Type
_,Type
t)) -> Label -> Type -> Assign
assign Label
lbl (Type -> Assign) -> CnvMonad Type -> CnvMonad Assign
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Path -> Type -> CnvMonad Type
evalTerm Path
path Type
t) [Assign]
rs
evalTerm Path
path (P Type
term Label
lbl) = Path -> Type -> CnvMonad Type
evalTerm (Label -> Path -> Path
CProj Label
lbl Path
path) Type
term
evalTerm Path
path (V Type
pt [Type]
ts)    =
   case Path
path of
     Path
CNil          -> Type -> [Type] -> Type
V Type
pt ([Type] -> Type) -> CnvMonad [Type] -> CnvMonad Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Type -> CnvMonad Type) -> [Type] -> CnvMonad [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Path -> Type -> CnvMonad Type
evalTerm Path
path) [Type]
ts
     CSel Type
trm Path
path ->
         do [Type]
vs <- Type -> CnvMonad [Type]
getAllParamValues Type
pt
            case Type -> [(Type, Type)] -> Maybe Type
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Type
trm ([Type] -> [Type] -> [(Type, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
vs [Type]
ts) of
              Just Type
t  -> Path -> Type -> CnvMonad Type
evalTerm Path
path Type
t
              Maybe Type
Nothing -> Doc -> CnvMonad Type
forall a a. Pretty a => a -> a
ppbug (Doc -> CnvMonad Type) -> Doc -> CnvMonad Type
forall a b. (a -> b) -> a -> b
$ FilePath
"evalTerm: missing value:"FilePath -> Type -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>Type
trm
                                 Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$ FilePath
"among:" FilePath -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>[Doc] -> Doc
forall a. Pretty a => [a] -> Doc
fsep ((Type -> Doc) -> [Type] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Type -> Doc
ppU Integer
10) [Type]
vs)
evalTerm Path
path (S Type
term Type
sel) = do Type
v <- Path -> Type -> CnvMonad Type
evalTerm Path
CNil Type
sel
                                Path -> Type -> CnvMonad Type
evalTerm (Type -> Path -> Path
CSel Type
v Path
path) Type
term
evalTerm Path
path (FV [Type]
terms)   = [Type] -> CnvMonad Type
forall a. [a] -> CnvMonad a
variants [Type]
terms CnvMonad Type -> (Type -> CnvMonad Type) -> CnvMonad Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Path -> Type -> CnvMonad Type
evalTerm Path
path
evalTerm Path
path (EInt SeqId
n)     = Type -> CnvMonad Type
forall (m :: * -> *) a. Monad m => a -> m a
return (SeqId -> Type
EInt SeqId
n)
evalTerm Path
path Type
t            = Doc -> CnvMonad Type
forall a a. Pretty a => a -> a
ppbug (FilePath
"evalTerm" FilePath -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> Type -> Doc
forall a. Pretty a => a -> Doc
parens Type
t)
--evalTerm path t            = ppbug (text "evalTerm" <+> sep [parens (text (show path)),parens (text (show t))])

getVarIndex :: Ident -> SeqId
getVarIndex Ident
x = SeqId -> (SeqId -> SeqId) -> Maybe SeqId -> SeqId
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SeqId
forall a. a
err SeqId -> SeqId
forall a. a -> a
id (Maybe SeqId -> SeqId) -> Maybe SeqId -> SeqId
forall a b. (a -> b) -> a -> b
$ Ident -> Maybe SeqId
getArgIndex Ident
x
  where err :: a
err = FilePath -> a
forall a a. Pretty a => a -> a
bug (FilePath
"getVarIndex "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Ident -> FilePath
forall a. Show a => a -> FilePath
show Ident
x)

----------------------------------------------------------------------
-- GrammarEnv

data PMCFGEnv = PMCFGEnv !ProdSet !FunSet
type ProdSet  = Set.Set Production
type FunSet   = Map.Map (UArray LIndex SeqId) FunId

emptyPMCFGEnv :: PMCFGEnv
emptyPMCFGEnv =
  ProdSet -> FunSet -> PMCFGEnv
PMCFGEnv ProdSet
forall a. Set a
Set.empty FunSet
forall k a. Map k a
Map.empty

addFunction :: PMCFGEnv -> FId -> UArray LIndex SeqId -> [[FId]] -> PMCFGEnv
addFunction :: PMCFGEnv -> SeqId -> UArray SeqId SeqId -> [[SeqId]] -> PMCFGEnv
addFunction (PMCFGEnv ProdSet
prodSet FunSet
funSet) !SeqId
fid UArray SeqId SeqId
fun [[SeqId]]
args =
  case UArray SeqId SeqId -> FunSet -> Maybe SeqId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UArray SeqId SeqId
fun FunSet
funSet of
    Just !SeqId
funid -> ProdSet -> FunSet -> PMCFGEnv
PMCFGEnv (Production -> ProdSet -> ProdSet
forall a. Ord a => a -> Set a -> Set a
Set.insert (SeqId -> SeqId -> [[SeqId]] -> Production
Production SeqId
fid SeqId
funid [[SeqId]]
args) ProdSet
prodSet)
                            FunSet
funSet
    Maybe SeqId
Nothing     -> let !funid :: SeqId
funid = FunSet -> SeqId
forall k a. Map k a -> SeqId
Map.size FunSet
funSet
                   in ProdSet -> FunSet -> PMCFGEnv
PMCFGEnv (Production -> ProdSet -> ProdSet
forall a. Ord a => a -> Set a -> Set a
Set.insert (SeqId -> SeqId -> [[SeqId]] -> Production
Production SeqId
fid SeqId
funid [[SeqId]]
args) ProdSet
prodSet)
                               (UArray SeqId SeqId -> SeqId -> FunSet -> FunSet
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert UArray SeqId SeqId
fun SeqId
funid FunSet
funSet)

getPMCFG :: PMCFGEnv -> PMCFG
getPMCFG :: PMCFGEnv -> PMCFG
getPMCFG (PMCFGEnv ProdSet
prodSet FunSet
funSet) =
  [Production] -> Array SeqId (UArray SeqId SeqId) -> PMCFG
PMCFG (ProdSet -> [Production]
optimize ProdSet
prodSet) (FunSet -> Array SeqId (UArray SeqId SeqId)
forall (a :: * -> * -> *) e. IArray a e => Map e SeqId -> a SeqId e
mkSetArray FunSet
funSet)
  where
    optimize :: ProdSet -> [Production]
optimize ProdSet
ps = ((SeqId, SeqId) -> [[[SeqId]]] -> [Production] -> [Production])
-> [Production] -> Map (SeqId, SeqId) [[[SeqId]]] -> [Production]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (SeqId, SeqId) -> [[[SeqId]]] -> [Production] -> [Production]
ff [] (([[[SeqId]]] -> [[[SeqId]]] -> [[[SeqId]]])
-> [((SeqId, SeqId), [[[SeqId]]])]
-> Map (SeqId, SeqId) [[[SeqId]]]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [[[SeqId]]] -> [[[SeqId]]] -> [[[SeqId]]]
forall a. [a] -> [a] -> [a]
(++) [((SeqId
fid,SeqId
funid),[[[SeqId]]
args]) | (Production SeqId
fid SeqId
funid [[SeqId]]
args) <- ProdSet -> [Production]
forall a. Set a -> [a]
Set.toList ProdSet
ps])
      where
        ff :: (FId,FunId) -> [[[FId]]] -> [Production] -> [Production]
        ff :: (SeqId, SeqId) -> [[[SeqId]]] -> [Production] -> [Production]
ff (SeqId
fid,SeqId
funid) [[[SeqId]]]
xs [Production]
prods
          | [SeqId] -> SeqId
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ((IntSet -> SeqId) -> [IntSet] -> [SeqId]
forall a b. (a -> b) -> [a] -> [b]
map IntSet -> SeqId
IntSet.size [IntSet]
ys) SeqId -> SeqId -> Bool
forall a. Eq a => a -> a -> Bool
== SeqId
count
                      = (SeqId -> SeqId -> [[SeqId]] -> Production
Production SeqId
fid SeqId
funid ((IntSet -> [SeqId]) -> [IntSet] -> [[SeqId]]
forall a b. (a -> b) -> [a] -> [b]
map IntSet -> [SeqId]
IntSet.toList [IntSet]
ys)) Production -> [Production] -> [Production]
forall a. a -> [a] -> [a]
: [Production]
prods
          | Bool
otherwise = ([[SeqId]] -> Production) -> [[[SeqId]]] -> [Production]
forall a b. (a -> b) -> [a] -> [b]
map (SeqId -> SeqId -> [[SeqId]] -> Production
Production SeqId
fid SeqId
funid) [[[SeqId]]]
xs [Production] -> [Production] -> [Production]
forall a. [a] -> [a] -> [a]
++ [Production]
prods
          where
            count :: SeqId
count = [SeqId] -> SeqId
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (([[SeqId]] -> SeqId) -> [[[SeqId]]] -> [SeqId]
forall a b. (a -> b) -> [a] -> [b]
map ([SeqId] -> SeqId
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([SeqId] -> SeqId) -> ([[SeqId]] -> [SeqId]) -> [[SeqId]] -> SeqId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([SeqId] -> SeqId) -> [[SeqId]] -> [SeqId]
forall a b. (a -> b) -> [a] -> [b]
map [SeqId] -> SeqId
forall (t :: * -> *) a. Foldable t => t a -> SeqId
length) [[[SeqId]]]
xs)
            ys :: [IntSet]
ys    = ([IntSet] -> [[SeqId]] -> [IntSet])
-> [IntSet] -> [[[SeqId]]] -> [IntSet]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((IntSet -> [SeqId] -> IntSet) -> [IntSet] -> [[SeqId]] -> [IntSet]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((SeqId -> IntSet -> IntSet) -> IntSet -> [SeqId] -> IntSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SeqId -> IntSet -> IntSet
IntSet.insert)) (IntSet -> [IntSet]
forall a. a -> [a]
repeat IntSet
IntSet.empty) [[[SeqId]]]
xs

------------------------------------------------------------
-- updating the MCF rule

restrictArg :: LIndex -> Path -> Term -> BacktrackM Env ()
restrictArg :: SeqId -> Path -> Type -> BacktrackM (ProtoFCat, [ProtoFCat]) ()
restrictArg SeqId
nr Path
path Type
index = do
  (ProtoFCat
head, [ProtoFCat]
args) <- BacktrackM (ProtoFCat, [ProtoFCat]) (ProtoFCat, [ProtoFCat])
forall s (m :: * -> *). MonadState s m => m s
get
  [ProtoFCat]
args <- (ProtoFCat -> BacktrackM (ProtoFCat, [ProtoFCat]) ProtoFCat)
-> SeqId
-> [ProtoFCat]
-> BacktrackM (ProtoFCat, [ProtoFCat]) [ProtoFCat]
forall (m :: * -> *) a.
Monad m =>
(a -> m a) -> SeqId -> [a] -> m [a]
updateNthM (Path
-> Type
-> ProtoFCat
-> BacktrackM (ProtoFCat, [ProtoFCat]) ProtoFCat
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Path -> Type -> ProtoFCat -> m ProtoFCat
restrictProtoFCat Path
path Type
index) SeqId
nr [ProtoFCat]
args
  (ProtoFCat, [ProtoFCat]) -> BacktrackM (ProtoFCat, [ProtoFCat]) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ProtoFCat
head, [ProtoFCat]
args)

restrictHead :: Path -> Term -> BacktrackM Env ()
restrictHead :: Path -> Type -> BacktrackM (ProtoFCat, [ProtoFCat]) ()
restrictHead Path
path Type
term = do
  (ProtoFCat
head, [ProtoFCat]
args) <- BacktrackM (ProtoFCat, [ProtoFCat]) (ProtoFCat, [ProtoFCat])
forall s (m :: * -> *). MonadState s m => m s
get
  ProtoFCat
head <- Path
-> Type
-> ProtoFCat
-> BacktrackM (ProtoFCat, [ProtoFCat]) ProtoFCat
forall (m :: * -> *).
(Functor m, MonadPlus m) =>
Path -> Type -> ProtoFCat -> m ProtoFCat
restrictProtoFCat Path
path Type
term ProtoFCat
head
  (ProtoFCat, [ProtoFCat]) -> BacktrackM (ProtoFCat, [ProtoFCat]) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ProtoFCat
head, [ProtoFCat]
args)

restrictProtoFCat :: (Functor m, MonadPlus m) => Path -> Term -> ProtoFCat -> m ProtoFCat
restrictProtoFCat :: Path -> Type -> ProtoFCat -> m ProtoFCat
restrictProtoFCat Path
path Type
v (PFCat Ident
cat SeqId
f Schema Identity SeqId (SeqId, [(Type, SeqId)])
schema) = do
  Schema Identity SeqId (SeqId, [(Type, SeqId)])
schema <- Path
-> Type
-> Schema Identity SeqId (SeqId, [(Type, SeqId)])
-> m (Schema Identity SeqId (SeqId, [(Type, SeqId)]))
forall (f :: * -> *) a s a b.
(Eq a, MonadPlus f) =>
Path
-> a
-> Schema Identity s (a, [(a, b)])
-> f (Schema Identity s (a, [(a, b)]))
addConstraint Path
path Type
v Schema Identity SeqId (SeqId, [(Type, SeqId)])
schema
  ProtoFCat -> m ProtoFCat
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident
-> SeqId
-> Schema Identity SeqId (SeqId, [(Type, SeqId)])
-> ProtoFCat
PFCat Ident
cat SeqId
f Schema Identity SeqId (SeqId, [(Type, SeqId)])
schema)
  where
    addConstraint :: Path
-> a
-> Schema Identity s (a, [(a, b)])
-> f (Schema Identity s (a, [(a, b)]))
addConstraint (CProj Label
lbl Path
path) a
v (CRec [(Label, Identity (Schema Identity s (a, [(a, b)])))]
rs)     = ([(Label, Identity (Schema Identity s (a, [(a, b)])))]
 -> Schema Identity s (a, [(a, b)]))
-> f [(Label, Identity (Schema Identity s (a, [(a, b)])))]
-> f (Schema Identity s (a, [(a, b)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Label, Identity (Schema Identity s (a, [(a, b)])))]
-> Schema Identity s (a, [(a, b)])
forall (b :: * -> *) s c.
[(Label, b (Schema b s c))] -> Schema b s c
CRec      (f [(Label, Identity (Schema Identity s (a, [(a, b)])))]
 -> f (Schema Identity s (a, [(a, b)])))
-> f [(Label, Identity (Schema Identity s (a, [(a, b)])))]
-> f (Schema Identity s (a, [(a, b)]))
forall a b. (a -> b) -> a -> b
$ Label
-> (Schema Identity s (a, [(a, b)])
    -> f (Schema Identity s (a, [(a, b)])))
-> [(Label, Identity (Schema Identity s (a, [(a, b)])))]
-> f [(Label, Identity (Schema Identity s (a, [(a, b)])))]
forall (m :: * -> *) t a.
(Monad m, Eq t) =>
t -> (a -> m a) -> [(t, Identity a)] -> m [(t, Identity a)]
update Label
lbl (Path
-> a
-> Schema Identity s (a, [(a, b)])
-> f (Schema Identity s (a, [(a, b)]))
addConstraint Path
path a
v) [(Label, Identity (Schema Identity s (a, [(a, b)])))]
rs
    addConstraint (CSel  Type
trm Path
path) a
v (CTbl Type
pt [(Type, Identity (Schema Identity s (a, [(a, b)])))]
cs)  = ([(Type, Identity (Schema Identity s (a, [(a, b)])))]
 -> Schema Identity s (a, [(a, b)]))
-> f [(Type, Identity (Schema Identity s (a, [(a, b)])))]
-> f (Schema Identity s (a, [(a, b)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type
-> [(Type, Identity (Schema Identity s (a, [(a, b)])))]
-> Schema Identity s (a, [(a, b)])
forall (b :: * -> *) s c.
Type -> [(Type, b (Schema b s c))] -> Schema b s c
CTbl Type
pt) (f [(Type, Identity (Schema Identity s (a, [(a, b)])))]
 -> f (Schema Identity s (a, [(a, b)])))
-> f [(Type, Identity (Schema Identity s (a, [(a, b)])))]
-> f (Schema Identity s (a, [(a, b)]))
forall a b. (a -> b) -> a -> b
$ Type
-> (Schema Identity s (a, [(a, b)])
    -> f (Schema Identity s (a, [(a, b)])))
-> [(Type, Identity (Schema Identity s (a, [(a, b)])))]
-> f [(Type, Identity (Schema Identity s (a, [(a, b)])))]
forall (m :: * -> *) t a.
(Monad m, Eq t) =>
t -> (a -> m a) -> [(t, Identity a)] -> m [(t, Identity a)]
update Type
trm (Path
-> a
-> Schema Identity s (a, [(a, b)])
-> f (Schema Identity s (a, [(a, b)]))
addConstraint Path
path a
v) [(Type, Identity (Schema Identity s (a, [(a, b)])))]
cs
    addConstraint Path
CNil             a
v (CPar (a
m,[(a, b)]
vs)) = case a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
v [(a, b)]
vs of
                                                       Just b
index -> Schema Identity s (a, [(a, b)])
-> f (Schema Identity s (a, [(a, b)]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, [(a, b)]) -> Schema Identity s (a, [(a, b)])
forall (b :: * -> *) s c. c -> Schema b s c
CPar (a
m,[(a
v,b
index)]))
                                                       Maybe b
Nothing    -> f (Schema Identity s (a, [(a, b)]))
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    addConstraint Path
CNil             a
v (CStr s
_)      = FilePath -> f (Schema Identity s (a, [(a, b)]))
forall a a. Pretty a => a -> a
bug FilePath
"restrictProtoFCat: string path"

    update :: t -> (a -> m a) -> [(t, Identity a)] -> m [(t, Identity a)]
update t
k0 a -> m a
f [] = [(t, Identity a)] -> m [(t, Identity a)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    update t
k0 a -> m a
f (x :: (t, Identity a)
x@(t
k,Identity a
v):[(t, Identity a)]
xs)
      | t
k0 t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
k    = do a
v <- a -> m a
f a
v
                        [(t, Identity a)] -> m [(t, Identity a)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((t
k,a -> Identity a
forall a. a -> Identity a
Identity a
v)(t, Identity a) -> [(t, Identity a)] -> [(t, Identity a)]
forall a. a -> [a] -> [a]
:[(t, Identity a)]
xs)
      | Bool
otherwise  = do [(t, Identity a)]
xs <- t -> (a -> m a) -> [(t, Identity a)] -> m [(t, Identity a)]
update t
k0 a -> m a
f [(t, Identity a)]
xs
                        [(t, Identity a)] -> m [(t, Identity a)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((t, Identity a)
x(t, Identity a) -> [(t, Identity a)] -> [(t, Identity a)]
forall a. a -> [a] -> [a]
:[(t, Identity a)]
xs)

mkArray :: [e] -> a SeqId e
mkArray    [e]
lst = (SeqId, SeqId) -> [e] -> a SeqId e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (SeqId
0,[e] -> SeqId
forall (t :: * -> *) a. Foldable t => t a -> SeqId
length [e]
lstSeqId -> SeqId -> SeqId
forall a. Num a => a -> a -> a
-SeqId
1) [e]
lst
mkSetArray :: Map e SeqId -> a SeqId e
mkSetArray Map e SeqId
map = (SeqId, SeqId) -> [(SeqId, e)] -> a SeqId e
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (SeqId
0,Map e SeqId -> SeqId
forall k a. Map k a -> SeqId
Map.size Map e SeqId
mapSeqId -> SeqId -> SeqId
forall a. Num a => a -> a -> a
-SeqId
1) [(SeqId
v,e
k) | (e
k,SeqId
v) <- Map e SeqId -> [(e, SeqId)]
forall k a. Map k a -> [(k, a)]
Map.toList Map e SeqId
map]

bug :: a -> a
bug a
msg = a -> a
forall a a. Pretty a => a -> a
ppbug a
msg
ppbug :: a -> a
ppbug a
msg = FilePath -> a
forall a. HasCallStack => FilePath -> a
error FilePath
completeMsg
 where
  originalMsg :: FilePath
originalMsg = Doc -> FilePath
forall a. Pretty a => a -> FilePath
render (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> SeqId -> a -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> SeqId -> a2 -> Doc
hang FilePath
"Internal error in GeneratePMCFG:" SeqId
4 a
msg
  completeMsg :: FilePath
completeMsg =
    case a -> FilePath
forall a. Pretty a => a -> FilePath
render a
msg of -- the error message for pattern matching a runtime string
      FilePath
"descend (CStr 0,CNil,CProj (LIdent (Id {rawId2utf8 = \"s\"})) CNil)"
        -> [FilePath] -> FilePath
unlines [FilePath
originalMsg -- add more helpful output
            ,FilePath
""
            ,FilePath
"1) Check that you are not trying to pattern match a /runtime string/."
            ,FilePath
"   These are illegal:"
            ,FilePath
"     lin Test foo = case foo.s of {"
            ,FilePath
"                       \"str\" => … } ;   <- explicit matching argument of a lin"
            ,FilePath
"     lin Test foo = opThatMatches foo   <- calling an oper that pattern matches"
            ,FilePath
""
            ,FilePath
"2) Not about pattern matching? Submit a bug report and we update the error message."
            ,FilePath
"     https://github.com/GrammaticalFramework/gf-core/issues"
            ]
      FilePath
_ -> FilePath
originalMsg -- any other message: just print it as is

ppU :: Integer -> Type -> Doc
ppU = TermPrintQual -> Integer -> Type -> Doc
forall t. (Ord t, Num t) => TermPrintQual -> t -> Type -> Doc
ppTerm TermPrintQual
Unqualified