-- | Translate grammars to Canonical form
-- (a common intermediate representation to simplify export to other formats)
module GF.Compile.GrammarToCanonical(
       grammar2canonical,abstract2canonical,concretes2canonical,
       projection,selection
       ) where
import Data.List(nub,partition)
import qualified Data.Map as M
import Data.Maybe(fromMaybe)
import qualified Data.Set as S
import GF.Data.ErrM
import GF.Text.Pretty
import GF.Grammar.Grammar as G
import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
import GF.Grammar.Lockfield(isLockLabel)
import GF.Grammar.Predef(cPredef,cInts)
import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
import GF.Infra.Option(Options,optionsPGF)
import PGF.Internal(Literal(..))
import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
import GF.Grammar.Canonical as C
import System.FilePath ((</>), (<.>))
import qualified Debug.Trace as T


-- | Generate Canonical code for the named abstract syntax and all associated
-- concrete syntaxes
grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
grammar2canonical :: Options -> ModuleName -> Grammar -> Grammar
grammar2canonical Options
opts ModuleName
absname Grammar
gr =
   Abstract -> [Concrete] -> Grammar
Grammar (ModuleName -> Grammar -> Abstract
abstract2canonical ModuleName
absname Grammar
gr)
           (((FilePath, Concrete) -> Concrete)
-> [(FilePath, Concrete)] -> [Concrete]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Concrete) -> Concrete
forall a b. (a, b) -> b
snd (Options -> ModuleName -> Grammar -> [(FilePath, Concrete)]
concretes2canonical Options
opts ModuleName
absname Grammar
gr))

-- | Generate Canonical code for the named abstract syntax
abstract2canonical :: ModuleName -> G.Grammar -> Abstract
abstract2canonical :: ModuleName -> Grammar -> Abstract
abstract2canonical ModuleName
absname Grammar
gr =
    ModId -> Flags -> [CatDef] -> [FunDef] -> Abstract
Abstract (ModuleName -> ModId
modId ModuleName
absname) (Grammar -> ModuleName -> Flags
convFlags Grammar
gr ModuleName
absname) [CatDef]
cats [FunDef]
funs
  where
    cats :: [CatDef]
cats = [CatId -> [CatId] -> CatDef
CatDef (Ident -> CatId
forall i. FromIdent i => Ident -> i
gId Ident
c) (Maybe (L [(BindType, Ident, Type)]) -> [CatId]
forall a b. Maybe (L [(a, b, Type)]) -> [CatId]
convCtx Maybe (L [(BindType, Ident, Type)])
ctx) | ((ModuleName
_,Ident
c),AbsCat Maybe (L [(BindType, Ident, Type)])
ctx) <- [(QIdent, Info)]
adefs]

    funs :: [FunDef]
funs = [FunId -> Type -> FunDef
FunDef (Ident -> FunId
forall i. FromIdent i => Ident -> i
gId Ident
f) (Type -> Type
convType Type
ty) |
            ((ModuleName
_,Ident
f),AbsFun (Just (L Location
_ Type
ty)) Maybe Int
ma Maybe [L Equation]
mdef Maybe Bool
_) <- [(QIdent, Info)]
adefs]

    adefs :: [(QIdent, Info)]
adefs = Grammar -> ModuleName -> [(QIdent, Info)]
allOrigInfos Grammar
gr ModuleName
absname

    convCtx :: Maybe (L [(a, b, Type)]) -> [CatId]
convCtx = [CatId]
-> (L [(a, b, Type)] -> [CatId])
-> Maybe (L [(a, b, Type)])
-> [CatId]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (((a, b, Type) -> CatId) -> [(a, b, Type)] -> [CatId]
forall a b. (a -> b) -> [a] -> [b]
map (a, b, Type) -> CatId
forall p a b. FromIdent p => (a, b, Type) -> p
convHypo ([(a, b, Type)] -> [CatId])
-> (L [(a, b, Type)] -> [(a, b, Type)])
-> L [(a, b, Type)]
-> [CatId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. L [(a, b, Type)] -> [(a, b, Type)]
forall a. L a -> a
unLoc)
    convHypo :: (a, b, Type) -> p
convHypo (a
bt,b
name,Type
t) =
      case Type -> ([(BindType, Ident, Type)], QIdent, [Type])
typeForm Type
t of
        ([],(ModuleName
_,Ident
cat),[]) -> Ident -> p
forall i. FromIdent i => Ident -> i
gId Ident
cat -- !!
        ([(BindType, Ident, Type)], QIdent, [Type])
tf -> FilePath -> p
forall a. HasCallStack => FilePath -> a
error (FilePath -> p) -> FilePath -> p
forall a b. (a -> b) -> a -> b
$ FilePath
"abstract2canonical convHypo: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ([(BindType, Ident, Type)], QIdent, [Type]) -> FilePath
forall a. Show a => a -> FilePath
show ([(BindType, Ident, Type)], QIdent, [Type])
tf

    convType :: Type -> Type
convType Type
t =
      case Type -> ([(BindType, Ident, Type)], QIdent, [Type])
typeForm Type
t of
        ([(BindType, Ident, Type)]
hyps,(ModuleName
_,Ident
cat),[Type]
args) -> [TypeBinding] -> TypeApp -> Type
Type [TypeBinding]
bs (CatId -> [Type] -> TypeApp
TypeApp (Ident -> CatId
forall i. FromIdent i => Ident -> i
gId Ident
cat) [Type]
as)
          where
            bs :: [TypeBinding]
bs = ((BindType, Ident, Type) -> TypeBinding)
-> [(BindType, Ident, Type)] -> [TypeBinding]
forall a b. (a -> b) -> [a] -> [b]
map (BindType, Ident, Type) -> TypeBinding
convHypo' [(BindType, Ident, Type)]
hyps
            as :: [Type]
as = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Type
convType [Type]
args

    convHypo' :: (BindType, Ident, Type) -> TypeBinding
convHypo' (BindType
bt,Ident
name,Type
t) = VarId -> Type -> TypeBinding
TypeBinding (Ident -> VarId
forall i. FromIdent i => Ident -> i
gId Ident
name) (Type -> Type
convType Type
t)

-- | Generate Canonical code for the all concrete syntaxes associated with
-- the named abstract syntax in given the grammar.
concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
concretes2canonical :: Options -> ModuleName -> Grammar -> [(FilePath, Concrete)]
concretes2canonical Options
opts ModuleName
absname Grammar
gr =
  [(FilePath
cncname,Grammar
-> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
concrete2canonical Grammar
gr GlobalEnv
cenv ModuleName
absname ModuleName
cnc ModuleInfo
cncmod)
     | let cenv :: GlobalEnv
cenv = Options -> Grammar -> GlobalEnv
resourceValues Options
opts Grammar
gr,
       ModuleName
cnc<-Grammar -> ModuleName -> [ModuleName]
allConcretes Grammar
gr ModuleName
absname,
       let cncname :: FilePath
cncname = FilePath
"canonical" FilePath -> FilePath -> FilePath
</> ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
render ModuleName
cnc FilePath -> FilePath -> FilePath
<.> FilePath
"gf"
           Ok ModuleInfo
cncmod = Grammar -> ModuleName -> Err ModuleInfo
forall (m :: * -> *).
ErrorMonad m =>
Grammar -> ModuleName -> m ModuleInfo
lookupModule Grammar
gr ModuleName
cnc
  ]

-- | Generate Canonical GF for the given concrete module.
concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
concrete2canonical :: Grammar
-> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
concrete2canonical Grammar
gr GlobalEnv
cenv ModuleName
absname ModuleName
cnc ModuleInfo
modinfo =
  ModId
-> ModId
-> Flags
-> [ParamDef]
-> [LincatDef]
-> [LinDef]
-> Concrete
Concrete (ModuleName -> ModId
modId ModuleName
cnc) (ModuleName -> ModId
modId ModuleName
absname) (Grammar -> ModuleName -> Flags
convFlags Grammar
gr ModuleName
cnc)
      (Set QIdent -> [QIdent] -> [ParamDef]
neededParamTypes Set QIdent
forall a. Set a
S.empty ([(Set QIdent, Either LincatDef LinDef)] -> [QIdent]
forall b. [(Set QIdent, b)] -> [QIdent]
params [(Set QIdent, Either LincatDef LinDef)]
defs))
      [LincatDef
lincat | (Set QIdent
_,Left LincatDef
lincat) <- [(Set QIdent, Either LincatDef LinDef)]
defs]
      [LinDef
lin | (Set QIdent
_,Right LinDef
lin) <- [(Set QIdent, Either LincatDef LinDef)]
defs]
  where
    defs :: [(Set QIdent, Either LincatDef LinDef)]
defs = ((Ident, Info) -> [(Set QIdent, Either LincatDef LinDef)])
-> [(Ident, Info)] -> [(Set QIdent, Either LincatDef LinDef)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Grammar
-> ModuleName
-> GlobalEnv
-> (Ident, Info)
-> [(Set QIdent, Either LincatDef LinDef)]
toCanonical Grammar
gr ModuleName
absname GlobalEnv
cenv) ([(Ident, Info)] -> [(Set QIdent, Either LincatDef LinDef)])
-> (Map Ident Info -> [(Ident, Info)])
-> Map Ident Info
-> [(Set QIdent, Either LincatDef LinDef)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
           Map Ident Info -> [(Ident, Info)]
forall k a. Map k a -> [(k, a)]
M.toList (Map Ident Info -> [(Set QIdent, Either LincatDef LinDef)])
-> Map Ident Info -> [(Set QIdent, Either LincatDef LinDef)]
forall a b. (a -> b) -> a -> b
$
           ModuleInfo -> Map Ident Info
jments ModuleInfo
modinfo

    params :: [(Set QIdent, b)] -> [QIdent]
params = Set QIdent -> [QIdent]
forall a. Set a -> [a]
S.toList (Set QIdent -> [QIdent])
-> ([(Set QIdent, b)] -> Set QIdent)
-> [(Set QIdent, b)]
-> [QIdent]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Set QIdent] -> Set QIdent
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set QIdent] -> Set QIdent)
-> ([(Set QIdent, b)] -> [Set QIdent])
-> [(Set QIdent, b)]
-> Set QIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Set QIdent, b) -> Set QIdent)
-> [(Set QIdent, b)] -> [Set QIdent]
forall a b. (a -> b) -> [a] -> [b]
map (Set QIdent, b) -> Set QIdent
forall a b. (a, b) -> a
fst

    neededParamTypes :: Set QIdent -> [QIdent] -> [ParamDef]
neededParamTypes Set QIdent
have [] = []
    neededParamTypes Set QIdent
have (QIdent
q:[QIdent]
qs) =
        if QIdent
q QIdent -> Set QIdent -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set QIdent
have
        then Set QIdent -> [QIdent] -> [ParamDef]
neededParamTypes Set QIdent
have [QIdent]
qs
        else let ((Set QIdent
got,Set QIdent
need),[ParamDef]
def) = Grammar -> QIdent -> ((Set QIdent, Set QIdent), [ParamDef])
paramType Grammar
gr QIdent
q
             in [ParamDef]
def[ParamDef] -> [ParamDef] -> [ParamDef]
forall a. [a] -> [a] -> [a]
++Set QIdent -> [QIdent] -> [ParamDef]
neededParamTypes (Set QIdent -> Set QIdent -> Set QIdent
forall a. Ord a => Set a -> Set a -> Set a
S.union Set QIdent
got Set QIdent
have) (Set QIdent -> [QIdent]
forall a. Set a -> [a]
S.toList Set QIdent
need[QIdent] -> [QIdent] -> [QIdent]
forall a. [a] -> [a] -> [a]
++[QIdent]
qs)

toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
toCanonical :: Grammar
-> ModuleName
-> GlobalEnv
-> (Ident, Info)
-> [(Set QIdent, Either LincatDef LinDef)]
toCanonical Grammar
gr ModuleName
absname GlobalEnv
cenv (Ident
name,Info
jment) =
  case Info
jment of
    CncCat (Just (L Location
loc Type
typ)) Maybe (L Type)
_ Maybe (L Type)
_ Maybe (L Type)
pprn Maybe PMCFG
_ ->
        [(Set QIdent
pts,LincatDef -> Either LincatDef LinDef
forall a b. a -> Either a b
Left (CatId -> LinType -> LincatDef
LincatDef (Ident -> CatId
forall i. FromIdent i => Ident -> i
gId Ident
name) (Type -> LinType
convType Type
ntyp)))]
      where
        pts :: Set QIdent
pts = Grammar -> Type -> Set QIdent
paramTypes Grammar
gr Type
ntyp
        ntyp :: Type
ntyp = Location -> Type -> Type
nf Location
loc Type
typ
    CncFun (Just r :: (Ident, [(BindType, Ident, Type)], Type)
r@(Ident
cat,[(BindType, Ident, Type)]
ctx,Type
lincat)) (Just (L Location
loc Type
def)) Maybe (L Type)
pprn Maybe PMCFG
_ ->
        [(Set QIdent
tts,LinDef -> Either LincatDef LinDef
forall a b. b -> Either a b
Right (FunId -> [VarId] -> LinValue -> LinDef
LinDef (Ident -> FunId
forall i. FromIdent i => Ident -> i
gId Ident
name) ((Ident -> VarId) -> [Ident] -> [VarId]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> VarId
forall i. FromIdent i => Ident -> i
gId [Ident]
args) (Grammar -> Type -> LinValue
convert Grammar
gr Type
e')))]
      where
        tts :: Set QIdent
tts = Grammar -> [Type] -> Set QIdent
tableTypes Grammar
gr [Type
e']

        e' :: Type
e' = Type -> Type -> Type
cleanupRecordFields Type
lincat (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
             Int -> Type -> Type
forall t. (Eq t, Num t) => t -> Type -> Type
unAbs ([(BindType, Ident)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(BindType, Ident)]
params) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
             Location -> Type -> Type
nf Location
loc ([(BindType, Ident)] -> Type -> Type
mkAbs [(BindType, Ident)]
params (Type -> [Type] -> Type
mkApp Type
def ((Ident -> Type) -> [Ident] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Type
Vr [Ident]
args)))
        params :: [(BindType, Ident)]
params = [(BindType
b,Ident
x)|(BindType
b,Ident
x,Type
_)<-[(BindType, Ident, Type)]
ctx]
        args :: [Ident]
args = ((BindType, Ident) -> Ident) -> [(BindType, Ident)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (BindType, Ident) -> Ident
forall a b. (a, b) -> b
snd [(BindType, Ident)]
params

    AnyInd Bool
_ ModuleName
m  -> case Grammar -> QIdent -> Err (ModuleName, Info)
forall (m :: * -> *).
ErrorMonad m =>
Grammar -> QIdent -> m (ModuleName, Info)
lookupOrigInfo Grammar
gr (ModuleName
m,Ident
name) of
                     Ok (ModuleName
m,Info
jment) -> Grammar
-> ModuleName
-> GlobalEnv
-> (Ident, Info)
-> [(Set QIdent, Either LincatDef LinDef)]
toCanonical Grammar
gr ModuleName
absname GlobalEnv
cenv (Ident
name,Info
jment)
                     Err (ModuleName, Info)
_ -> []
    Info
_ -> []
  where
    nf :: Location -> Type -> Type
nf Location
loc = GlobalEnv -> L Ident -> Type -> Type
normalForm GlobalEnv
cenv (Location -> Ident -> L Ident
forall a. Location -> a -> L a
L Location
loc Ident
name)

    unAbs :: t -> Type -> Type
unAbs t
0 Type
t = Type
t
    unAbs t
n (Abs BindType
_ Ident
_ Type
t) = t -> Type -> Type
unAbs (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) Type
t
    unAbs t
_ Type
t = Type
t

tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
tableTypes :: Grammar -> [Type] -> Set QIdent
tableTypes Grammar
gr [Type]
ts = [Set QIdent] -> Set QIdent
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Type -> Set QIdent) -> [Type] -> [Set QIdent]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Set QIdent
tabtys [Type]
ts)
  where
    tabtys :: Type -> Set QIdent
tabtys Type
t =
      case Type
t of
        V Type
t [Type]
cc -> Set QIdent -> Set QIdent -> Set QIdent
forall a. Ord a => Set a -> Set a -> Set a
S.union (Grammar -> Type -> Set QIdent
paramTypes Grammar
gr Type
t) (Grammar -> [Type] -> Set QIdent
tableTypes Grammar
gr [Type]
cc)
        T (TTyped Type
t) [Case]
cs -> Set QIdent -> Set QIdent -> Set QIdent
forall a. Ord a => Set a -> Set a -> Set a
S.union (Grammar -> Type -> Set QIdent
paramTypes Grammar
gr Type
t) (Grammar -> [Type] -> Set QIdent
tableTypes Grammar
gr ((Case -> Type) -> [Case] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Case -> Type
forall a b. (a, b) -> b
snd [Case]
cs))
        Type
_ -> (Type -> Set QIdent) -> Type -> Set QIdent
forall m. Monoid m => (Type -> m) -> Type -> m
collectOp Type -> Set QIdent
tabtys Type
t

paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
paramTypes :: Grammar -> Type -> Set QIdent
paramTypes Grammar
gr Type
t =
  case Type
t of
    RecType [Labelling]
fs -> [Set QIdent] -> Set QIdent
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Labelling -> Set QIdent) -> [Labelling] -> [Set QIdent]
forall a b. (a -> b) -> [a] -> [b]
map (Grammar -> Type -> Set QIdent
paramTypes Grammar
gr(Type -> Set QIdent)
-> (Labelling -> Type) -> Labelling -> Set QIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Labelling -> Type
forall a b. (a, b) -> b
snd) [Labelling]
fs)
    Table Type
t1 Type
t2 -> Set QIdent -> Set QIdent -> Set QIdent
forall a. Ord a => Set a -> Set a -> Set a
S.union (Grammar -> Type -> Set QIdent
paramTypes Grammar
gr Type
t1) (Grammar -> Type -> Set QIdent
paramTypes Grammar
gr Type
t2)
    App Type
tf Type
ta -> Set QIdent -> Set QIdent -> Set QIdent
forall a. Ord a => Set a -> Set a -> Set a
S.union (Grammar -> Type -> Set QIdent
paramTypes Grammar
gr Type
tf) (Grammar -> Type -> Set QIdent
paramTypes Grammar
gr Type
ta)
    Sort Ident
_ -> Set QIdent
forall a. Set a
S.empty
    EInt Int
_ -> Set QIdent
forall a. Set a
S.empty
    Q QIdent
q -> QIdent -> Set QIdent
lookup QIdent
q
    QC QIdent
q -> QIdent -> Set QIdent
lookup QIdent
q
    FV [Type]
ts -> [Set QIdent] -> Set QIdent
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ((Type -> Set QIdent) -> [Type] -> [Set QIdent]
forall a b. (a -> b) -> [a] -> [b]
map (Grammar -> Type -> Set QIdent
paramTypes Grammar
gr) [Type]
ts)
    Type
_ -> Set QIdent
forall a. Set a
ignore
  where
    lookup :: QIdent -> Set QIdent
lookup QIdent
q = case Grammar -> QIdent -> Err (ModuleName, Info)
forall (m :: * -> *).
ErrorMonad m =>
Grammar -> QIdent -> m (ModuleName, Info)
lookupOrigInfo Grammar
gr QIdent
q of
                 Ok (ModuleName
_,ResOper  Maybe (L Type)
_ (Just (L Location
_ Type
t))) ->
                                       QIdent -> Set QIdent -> Set QIdent
forall a. Ord a => a -> Set a -> Set a
S.insert QIdent
q (Grammar -> Type -> Set QIdent
paramTypes Grammar
gr Type
t)
                 Ok (ModuleName
_,ResParam {}) -> QIdent -> Set QIdent
forall a. a -> Set a
S.singleton QIdent
q
                 Err (ModuleName, Info)
_ -> Set QIdent
forall a. Set a
ignore

    ignore :: Set a
ignore = FilePath -> Set a -> Set a
forall a. FilePath -> a -> a
T.trace (FilePath
"Ignore: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Type -> FilePath
forall a. Show a => a -> FilePath
show Type
t) Set a
forall a. Set a
S.empty

-- | Filter out record fields from definitions which don't appear in lincat.
cleanupRecordFields :: G.Type -> Term -> Term
cleanupRecordFields :: Type -> Type -> Type
cleanupRecordFields (RecType [Labelling]
ls) (R [Assign]
as) =
  let defnFields :: Map Label Type
defnFields = [Labelling] -> Map Label Type
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [Labelling]
ls
  in [Assign] -> Type
R
      [ (Label
lbl, (Maybe Type
mty, Type
t'))
      | (Label
lbl, (Maybe Type
mty, Type
t)) <- [Assign]
as
      , Label -> Map Label Type -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Label
lbl Map Label Type
defnFields
      , let Just Type
ty = Label -> Map Label Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Label
lbl Map Label Type
defnFields
      , let t' :: Type
t' = Type -> Type -> Type
cleanupRecordFields Type
ty Type
t
      ]
cleanupRecordFields Type
ty t :: Type
t@(FV [Type]
_) = (Type -> Type) -> Type -> Type
composSafeOp (Type -> Type -> Type
cleanupRecordFields Type
ty) Type
t
cleanupRecordFields Type
_ Type
t = Type
t

convert :: G.Grammar -> Term -> LinValue
convert :: Grammar -> Type -> LinValue
convert Grammar
gr = Grammar -> [Ident] -> Type -> LinValue
convert' Grammar
gr []

convert' :: G.Grammar -> [Ident] -> Term -> LinValue
convert' :: Grammar -> [Ident] -> Type -> LinValue
convert' Grammar
gr [Ident]
vs = Type -> LinValue
ppT
  where
    ppT0 :: Type -> LinValue
ppT0 = Grammar -> [Ident] -> Type -> LinValue
convert' Grammar
gr [Ident]
vs
    ppTv :: [Ident] -> Type -> LinValue
ppTv [Ident]
vs' = Grammar -> [Ident] -> Type -> LinValue
convert' Grammar
gr [Ident]
vs'

    ppT :: Type -> LinValue
ppT Type
t =
      case Type
t of
--      Abs b x t -> ...
--      V ty ts -> VTableValue (convType ty) (map ppT ts)
        V Type
ty [Type]
ts -> LinType -> [TableRowValue] -> LinValue
TableValue (Type -> LinType
convType Type
ty) [LinPattern -> LinValue -> TableRowValue
forall rhs. LinPattern -> rhs -> TableRow rhs
TableRow (Patt -> LinPattern
ppP Patt
p) (Type -> LinValue
ppT Type
t)|(Patt
p,Type
t)<-[Patt] -> [Type] -> [Case]
forall a b. [a] -> [b] -> [(a, b)]
zip [Patt]
ps [Type]
ts]
          where
            Ok [Type]
pts = Grammar -> Type -> Err [Type]
forall (m :: * -> *). ErrorMonad m => Grammar -> Type -> m [Type]
allParamValues Grammar
gr Type
ty
            Ok [Patt]
ps = (Type -> Err Patt) -> [Type] -> Err [Patt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Err Patt
term2patt [Type]
pts
        T (TTyped Type
ty) [Case]
cs -> LinType -> [TableRowValue] -> LinValue
TableValue (Type -> LinType
convType Type
ty) ((Case -> TableRowValue) -> [Case] -> [TableRowValue]
forall a b. (a -> b) -> [a] -> [b]
map Case -> TableRowValue
ppCase [Case]
cs)
        S Type
t Type
p -> LinValue -> LinValue -> LinValue
selection (Type -> LinValue
ppT Type
t) (Type -> LinValue
ppT Type
p)
        C Type
t1 Type
t2 -> LinValue -> LinValue -> LinValue
concatValue (Type -> LinValue
ppT Type
t1) (Type -> LinValue
ppT Type
t2)
        App Type
f Type
a -> LinValue -> LinValue -> LinValue
ap (Type -> LinValue
ppT Type
f) (Type -> LinValue
ppT Type
a)
        R [Assign]
r -> [RecordRowValue] -> LinValue
RecordValue ([Assign] -> [RecordRowValue]
fields ([Assign] -> [Assign]
forall a. [(Label, a)] -> [(Label, a)]
sortRec [Assign]
r))
        P Type
t Label
l -> LinValue -> LabelId -> LinValue
projection (Type -> LinValue
ppT Type
t) (Label -> LabelId
lblId Label
l)
        Vr Ident
x -> VarValueId -> LinValue
VarValue (Ident -> VarValueId
forall i. FromIdent i => Ident -> i
gId Ident
x)
        Cn Ident
x -> VarValueId -> LinValue
VarValue (Ident -> VarValueId
forall i. FromIdent i => Ident -> i
gId Ident
x) -- hmm
        Con Ident
c -> ParamValue -> LinValue
ParamConstant (ParamId -> [LinValue] -> ParamValue
forall arg. ParamId -> [arg] -> Param arg
Param (Ident -> ParamId
forall i. FromIdent i => Ident -> i
gId Ident
c) [])
        Sort Ident
k -> VarValueId -> LinValue
VarValue (Ident -> VarValueId
forall i. FromIdent i => Ident -> i
gId Ident
k)
        EInt Int
n -> LinLiteral -> LinValue
LiteralValue (Int -> LinLiteral
IntConstant Int
n)
        Q (ModuleName
m,Ident
n) -> if ModuleName
mModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
==ModuleName
cPredef then Ident -> LinValue
ppPredef Ident
n else VarValueId -> LinValue
VarValue (ModuleName -> Ident -> VarValueId
forall i. QualIdent i => ModuleName -> Ident -> i
gQId ModuleName
m Ident
n)
        QC (ModuleName
m,Ident
n) -> ParamValue -> LinValue
ParamConstant (ParamId -> [LinValue] -> ParamValue
forall arg. ParamId -> [arg] -> Param arg
Param (ModuleName -> Ident -> ParamId
forall i. QualIdent i => ModuleName -> Ident -> i
gQId ModuleName
m Ident
n) [])
        K FilePath
s -> LinLiteral -> LinValue
LiteralValue (FilePath -> LinLiteral
StrConstant FilePath
s)
        Type
Empty -> LinLiteral -> LinValue
LiteralValue (FilePath -> LinLiteral
StrConstant FilePath
"")
        FV [Type]
ts -> [LinValue] -> LinValue
VariantValue ((Type -> LinValue) -> [Type] -> [LinValue]
forall a b. (a -> b) -> [a] -> [b]
map Type -> LinValue
ppT [Type]
ts)
        Alts Type
t' [(Type, Type)]
vs -> [(Type, Type)] -> LinValue -> LinValue
alts [(Type, Type)]
vs (Type -> LinValue
ppT Type
t')
        Type
_ -> FilePath -> LinValue
forall a. HasCallStack => FilePath -> a
error (FilePath -> LinValue) -> FilePath -> LinValue
forall a b. (a -> b) -> a -> b
$ FilePath
"convert' ppT: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Type -> FilePath
forall a. Show a => a -> FilePath
show Type
t

    ppCase :: Case -> TableRowValue
ppCase (Patt
p,Type
t) = LinPattern -> LinValue -> TableRowValue
forall rhs. LinPattern -> rhs -> TableRow rhs
TableRow (Patt -> LinPattern
ppP Patt
p) ([Ident] -> Type -> LinValue
ppTv (Patt -> [Ident]
patVars Patt
p[Ident] -> [Ident] -> [Ident]
forall a. [a] -> [a] -> [a]
++[Ident]
vs) Type
t)

    ppPredef :: Ident -> LinValue
ppPredef Ident
n =
      case Ident -> Err Predefined
forall (m :: * -> *). MonadFail m => Ident -> m Predefined
predef Ident
n of
        Ok Predefined
BIND       -> FilePath -> LinValue
p FilePath
"BIND"
        Ok Predefined
SOFT_BIND  -> FilePath -> LinValue
p FilePath
"SOFT_BIND"
        Ok Predefined
SOFT_SPACE -> FilePath -> LinValue
p FilePath
"SOFT_SPACE"
        Ok Predefined
CAPIT      -> FilePath -> LinValue
p FilePath
"CAPIT"
        Ok Predefined
ALL_CAPIT  -> FilePath -> LinValue
p FilePath
"ALL_CAPIT"
        Err Predefined
_ -> VarValueId -> LinValue
VarValue (ModuleName -> Ident -> VarValueId
forall i. QualIdent i => ModuleName -> Ident -> i
gQId ModuleName
cPredef Ident
n) -- hmm
      where
       p :: FilePath -> LinValue
p = PredefId -> LinValue
PredefValue (PredefId -> LinValue)
-> (FilePath -> PredefId) -> FilePath -> LinValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> PredefId
PredefId (Id -> PredefId) -> (FilePath -> Id) -> FilePath -> PredefId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Id
rawIdentS

    ppP :: Patt -> LinPattern
ppP Patt
p =
      case Patt
p of
        PC Ident
c [Patt]
ps -> ParamPattern -> LinPattern
ParamPattern (ParamId -> [LinPattern] -> ParamPattern
forall arg. ParamId -> [arg] -> Param arg
Param (Ident -> ParamId
forall i. FromIdent i => Ident -> i
gId Ident
c) ((Patt -> LinPattern) -> [Patt] -> [LinPattern]
forall a b. (a -> b) -> [a] -> [b]
map Patt -> LinPattern
ppP [Patt]
ps))
        PP (ModuleName
m,Ident
c) [Patt]
ps -> ParamPattern -> LinPattern
ParamPattern (ParamId -> [LinPattern] -> ParamPattern
forall arg. ParamId -> [arg] -> Param arg
Param (ModuleName -> Ident -> ParamId
forall i. QualIdent i => ModuleName -> Ident -> i
gQId ModuleName
m Ident
c) ((Patt -> LinPattern) -> [Patt] -> [LinPattern]
forall a b. (a -> b) -> [a] -> [b]
map Patt -> LinPattern
ppP [Patt]
ps))
        PR [(Label, Patt)]
r -> [RecordRow LinPattern] -> LinPattern
RecordPattern ([(Label, Patt)] -> [RecordRow LinPattern]
fields [(Label, Patt)]
r) {-
        PW -> WildPattern
        PV x -> VarP x
        PString s -> Lit (show s) -- !!
        PInt i -> Lit (show i)
        PFloat x -> Lit (show x)
        PT _ p -> ppP p
        PAs x p -> AsP x (ppP p) -}
        Patt
_ -> FilePath -> LinPattern
forall a. HasCallStack => FilePath -> a
error (FilePath -> LinPattern) -> FilePath -> LinPattern
forall a b. (a -> b) -> a -> b
$ FilePath
"convert' ppP: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Patt -> FilePath
forall a. Show a => a -> FilePath
show Patt
p
      where
        fields :: [(Label, Patt)] -> [RecordRow LinPattern]
fields = ((Label, Patt) -> RecordRow LinPattern)
-> [(Label, Patt)] -> [RecordRow LinPattern]
forall a b. (a -> b) -> [a] -> [b]
map (Label, Patt) -> RecordRow LinPattern
field ([(Label, Patt)] -> [RecordRow LinPattern])
-> ([(Label, Patt)] -> [(Label, Patt)])
-> [(Label, Patt)]
-> [RecordRow LinPattern]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Label, Patt) -> Bool) -> [(Label, Patt)] -> [(Label, Patt)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> ((Label, Patt) -> Bool) -> (Label, Patt) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Label -> Bool
isLockLabel(Label -> Bool)
-> ((Label, Patt) -> Label) -> (Label, Patt) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Label, Patt) -> Label
forall a b. (a, b) -> a
fst)
        field :: (Label, Patt) -> RecordRow LinPattern
field (Label
l,Patt
p) = LabelId -> LinPattern -> RecordRow LinPattern
forall rhs. LabelId -> rhs -> RecordRow rhs
RecordRow (Label -> LabelId
lblId Label
l) (Patt -> LinPattern
ppP Patt
p)

--  patToParam p = case ppP p of ParamPattern pv -> pv

--  token s = single (c "TK" `Ap` lit s)

    alts :: [(Type, Type)] -> LinValue -> LinValue
alts [(Type, Type)]
vs = [([FilePath], LinValue)] -> LinValue -> LinValue
PreValue (((Type, Type) -> ([FilePath], LinValue))
-> [(Type, Type)] -> [([FilePath], LinValue)]
forall a b. (a -> b) -> [a] -> [b]
map (Type, Type) -> ([FilePath], LinValue)
alt [(Type, Type)]
vs)
      where
        alt :: (Type, Type) -> ([FilePath], LinValue)
alt (Type
t,Type
p) = (Type -> [FilePath]
pre Type
p,Type -> LinValue
ppT0 Type
t)

        pre :: Type -> [FilePath]
pre (K FilePath
s) = [FilePath
s]
        pre Type
Empty = [FilePath
""]  -- Empty == K ""
        pre (Strs [Type]
ts) = (Type -> [FilePath]) -> [Type] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> [FilePath]
pre [Type]
ts
        pre (EPatt Patt
p) = Patt -> [FilePath]
pat Patt
p
        pre Type
t = FilePath -> [FilePath]
forall a. HasCallStack => FilePath -> a
error (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath
"convert' alts pre: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Type -> FilePath
forall a. Show a => a -> FilePath
show Type
t

        pat :: Patt -> [FilePath]
pat (PString FilePath
s) = [FilePath
s]
        pat (PAlt Patt
p1 Patt
p2) = Patt -> [FilePath]
pat Patt
p1[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++Patt -> [FilePath]
pat Patt
p2
        pat (PSeq Patt
p1 Patt
p2) = [FilePath
s1FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
s2 | FilePath
s1<-Patt -> [FilePath]
pat Patt
p1, FilePath
s2<-Patt -> [FilePath]
pat Patt
p2]
        pat Patt
p = FilePath -> [FilePath]
forall a. HasCallStack => FilePath -> a
error (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath
"convert' alts pat: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Patt -> FilePath
forall a. Show a => a -> FilePath
show Patt
p

    fields :: [Assign] -> [RecordRowValue]
fields = (Assign -> RecordRowValue) -> [Assign] -> [RecordRowValue]
forall a b. (a -> b) -> [a] -> [b]
map Assign -> RecordRowValue
field ([Assign] -> [RecordRowValue])
-> ([Assign] -> [Assign]) -> [Assign] -> [RecordRowValue]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Assign -> Bool) -> [Assign] -> [Assign]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (Assign -> Bool) -> Assign -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Label -> Bool
isLockLabel(Label -> Bool) -> (Assign -> Label) -> Assign -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Assign -> Label
forall a b. (a, b) -> a
fst)
    field :: Assign -> RecordRowValue
field (Label
l,(Maybe Type
_,Type
t)) = LabelId -> LinValue -> RecordRowValue
forall rhs. LabelId -> rhs -> RecordRow rhs
RecordRow (Label -> LabelId
lblId Label
l) (Type -> LinValue
ppT Type
t)
  --c = Const
  --c = VarValue . VarValueId
  --lit s = c (show s) -- hmm

    ap :: LinValue -> LinValue -> LinValue
ap LinValue
f LinValue
a = case LinValue
f of
               ParamConstant (Param ParamId
p [LinValue]
ps) ->
                 ParamValue -> LinValue
ParamConstant (ParamId -> [LinValue] -> ParamValue
forall arg. ParamId -> [arg] -> Param arg
Param ParamId
p ([LinValue]
ps[LinValue] -> [LinValue] -> [LinValue]
forall a. [a] -> [a] -> [a]
++[LinValue
a]))
               LinValue
_ -> FilePath -> LinValue
forall a. HasCallStack => FilePath -> a
error (FilePath -> LinValue) -> FilePath -> LinValue
forall a b. (a -> b) -> a -> b
$ FilePath
"convert' ap: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Doc -> FilePath
forall a. Pretty a => a -> FilePath
render (LinValue -> Doc
forall a. PPA a => a -> Doc
ppA LinValue
f Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> LinValue -> Doc
forall a. PPA a => a -> Doc
ppA LinValue
a)

concatValue :: LinValue -> LinValue -> LinValue
concatValue :: LinValue -> LinValue -> LinValue
concatValue LinValue
v1 LinValue
v2 =
  case (LinValue
v1,LinValue
v2) of
    (LiteralValue (StrConstant FilePath
""),LinValue
_) -> LinValue
v2
    (LinValue
_,LiteralValue (StrConstant FilePath
"")) -> LinValue
v1
    (LinValue, LinValue)
_ -> LinValue -> LinValue -> LinValue
ConcatValue LinValue
v1 LinValue
v2

-- | Smart constructor for projections
projection :: LinValue -> LabelId -> LinValue
projection :: LinValue -> LabelId -> LinValue
projection LinValue
r LabelId
l = LinValue -> Maybe LinValue -> LinValue
forall a. a -> Maybe a -> a
fromMaybe (LinValue -> LabelId -> LinValue
Projection LinValue
r LabelId
l) (LinValue -> LabelId -> Maybe LinValue
proj LinValue
r LabelId
l)

proj :: LinValue -> LabelId -> Maybe LinValue
proj :: LinValue -> LabelId -> Maybe LinValue
proj LinValue
r LabelId
l =
  case LinValue
r of
    RecordValue [RecordRowValue]
r -> case [LinValue
v | RecordRow LabelId
l' LinValue
v <- [RecordRowValue]
r, LabelId
l'LabelId -> LabelId -> Bool
forall a. Eq a => a -> a -> Bool
==LabelId
l] of
                          [LinValue
v] -> LinValue -> Maybe LinValue
forall a. a -> Maybe a
Just LinValue
v
                          [LinValue]
_ -> Maybe LinValue
forall a. Maybe a
Nothing
    LinValue
_ -> Maybe LinValue
forall a. Maybe a
Nothing

-- | Smart constructor for selections
selection :: LinValue -> LinValue -> LinValue
selection :: LinValue -> LinValue -> LinValue
selection LinValue
t LinValue
v =
  -- Note: impossible cases can become possible after grammar transformation
  case LinValue
t of
    TableValue LinType
tt [TableRowValue]
r ->
        case [LinValue] -> [LinValue]
forall a. Eq a => [a] -> [a]
nub [LinValue
rv | TableRow LinPattern
_ LinValue
rv <- [TableRowValue]
keep] of
          [LinValue
rv] -> LinValue
rv
          [LinValue]
_ -> LinValue -> LinValue -> LinValue
Selection (LinType -> [TableRowValue] -> LinValue
TableValue LinType
tt [TableRowValue]
r') LinValue
v
      where
        -- Don't introduce wildcard patterns, true to the canonical format,
        -- annotate (or eliminate) rhs in impossible rows
        r' :: [TableRowValue]
r' = (TableRowValue -> TableRowValue)
-> [TableRowValue] -> [TableRowValue]
forall a b. (a -> b) -> [a] -> [b]
map TableRowValue -> TableRowValue
trunc [TableRowValue]
r
        trunc :: TableRowValue -> TableRowValue
trunc r :: TableRowValue
r@(TableRow LinPattern
p LinValue
e) = if LinValue -> TableRowValue -> Bool
forall rhs. LinValue -> TableRow rhs -> Bool
mightMatchRow LinValue
v TableRowValue
r
                                 then TableRowValue
r
                                 else LinPattern -> LinValue -> TableRowValue
forall rhs. LinPattern -> rhs -> TableRow rhs
TableRow LinPattern
p (LinValue -> LinValue
impossible LinValue
e)
        {-
        -- Creates smaller tables, but introduces wildcard patterns
        r' = if null discard
             then r
             else keep++[TableRow WildPattern impossible]
        -}
        ([TableRowValue]
keep,[TableRowValue]
discard) = (TableRowValue -> Bool)
-> [TableRowValue] -> ([TableRowValue], [TableRowValue])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (LinValue -> TableRowValue -> Bool
forall rhs. LinValue -> TableRow rhs -> Bool
mightMatchRow LinValue
v) [TableRowValue]
r
    LinValue
_ -> LinValue -> LinValue -> LinValue
Selection LinValue
t LinValue
v

impossible :: LinValue -> LinValue
impossible :: LinValue -> LinValue
impossible = FilePath -> LinValue -> LinValue
CommentedValue FilePath
"impossible"

mightMatchRow :: LinValue -> TableRow rhs -> Bool
mightMatchRow :: LinValue -> TableRow rhs -> Bool
mightMatchRow LinValue
v (TableRow LinPattern
p rhs
_) =
  case LinPattern
p of
    LinPattern
WildPattern -> Bool
True
    LinPattern
_ -> LinValue -> LinPattern -> Bool
mightMatch LinValue
v LinPattern
p

mightMatch :: LinValue -> LinPattern -> Bool
mightMatch :: LinValue -> LinPattern -> Bool
mightMatch LinValue
v LinPattern
p =
  case LinValue
v of
    ConcatValue LinValue
_ LinValue
_ -> Bool
False
    ParamConstant (Param ParamId
c1 [LinValue]
pvs) ->
      case LinPattern
p of
        ParamPattern (Param ParamId
c2 [LinPattern]
pps) -> ParamId
c1ParamId -> ParamId -> Bool
forall a. Eq a => a -> a -> Bool
==ParamId
c2 Bool -> Bool -> Bool
&& [LinValue] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LinValue]
pvsInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==[LinPattern] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LinPattern]
pps Bool -> Bool -> Bool
&&
                                       [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [LinValue -> LinPattern -> Bool
mightMatch LinValue
v LinPattern
p|(LinValue
v,LinPattern
p)<-[LinValue] -> [LinPattern] -> [(LinValue, LinPattern)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LinValue]
pvs [LinPattern]
pps]
        LinPattern
_ -> Bool
False
    RecordValue [RecordRowValue]
rv ->
      case LinPattern
p of
        RecordPattern [RecordRow LinPattern]
rp ->
          [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool -> (LinValue -> Bool) -> Maybe LinValue -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (LinValue -> LinPattern -> Bool
`mightMatch` LinPattern
p) (LinValue -> LabelId -> Maybe LinValue
proj LinValue
v LabelId
l) | RecordRow LabelId
l LinPattern
p<-[RecordRow LinPattern]
rp]
        LinPattern
_ -> Bool
False
    LinValue
_ -> Bool
True

patVars :: Patt -> [Ident]
patVars :: Patt -> [Ident]
patVars Patt
p =
  case Patt
p of
    PV Ident
x -> [Ident
x]
    PAs Ident
x Patt
p -> Ident
xIdent -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
:Patt -> [Ident]
patVars Patt
p
    Patt
_ -> (Patt -> [Ident]) -> Patt -> [Ident]
forall a. (Patt -> [a]) -> Patt -> [a]
collectPattOp Patt -> [Ident]
patVars Patt
p

convType :: Term -> LinType
convType :: Type -> LinType
convType = Type -> LinType
ppT
  where
    ppT :: Type -> LinType
ppT Type
t =
      case Type
t of
        Table Type
ti Type
tv -> LinType -> LinType -> LinType
TableType (Type -> LinType
ppT Type
ti) (Type -> LinType
ppT Type
tv)
        RecType [Labelling]
rt -> [RecordRowType] -> LinType
RecordType ([Labelling] -> [RecordRowType]
convFields [Labelling]
rt)
--      App tf ta -> TAp (ppT tf) (ppT ta)
--      FV [] -> tcon0 (identS "({-empty variant-})")
        Sort Ident
k -> Ident -> LinType
convSort Ident
k
--      EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
        FV (Type
t:[Type]
ts) -> Type -> LinType
ppT Type
t -- !!
        QC (ModuleName
m,Ident
n) -> ParamType -> LinType
ParamType (ParamId -> ParamType
ParamTypeId (ModuleName -> Ident -> ParamId
forall i. QualIdent i => ModuleName -> Ident -> i
gQId ModuleName
m Ident
n))
        Q (ModuleName
m,Ident
n) -> ParamType -> LinType
ParamType (ParamId -> ParamType
ParamTypeId (ModuleName -> Ident -> ParamId
forall i. QualIdent i => ModuleName -> Ident -> i
gQId ModuleName
m Ident
n))
        Type
_ -> FilePath -> LinType
forall a. HasCallStack => FilePath -> a
error (FilePath -> LinType) -> FilePath -> LinType
forall a b. (a -> b) -> a -> b
$ FilePath
"convType ppT: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Type -> FilePath
forall a. Show a => a -> FilePath
show Type
t

    convFields :: [Labelling] -> [RecordRowType]
convFields = (Labelling -> RecordRowType) -> [Labelling] -> [RecordRowType]
forall a b. (a -> b) -> [a] -> [b]
map Labelling -> RecordRowType
convField ([Labelling] -> [RecordRowType])
-> ([Labelling] -> [Labelling]) -> [Labelling] -> [RecordRowType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Labelling -> Bool) -> [Labelling] -> [Labelling]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (Labelling -> Bool) -> Labelling -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Label -> Bool
isLockLabel(Label -> Bool) -> (Labelling -> Label) -> Labelling -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Labelling -> Label
forall a b. (a, b) -> a
fst)
    convField :: Labelling -> RecordRowType
convField (Label
l,Type
r) = LabelId -> LinType -> RecordRowType
forall rhs. LabelId -> rhs -> RecordRow rhs
RecordRow (Label -> LabelId
lblId Label
l) (Type -> LinType
ppT Type
r)

    convSort :: Ident -> LinType
convSort Ident
k = case Ident -> FilePath
showIdent Ident
k of
                   FilePath
"Float" -> LinType
FloatType
                   FilePath
"Int" -> LinType
IntType
                   FilePath
"Str" -> LinType
StrType
                   FilePath
_ -> FilePath -> LinType
forall a. HasCallStack => FilePath -> a
error (FilePath -> LinType) -> FilePath -> LinType
forall a b. (a -> b) -> a -> b
$ FilePath
"convType convSort: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Ident -> FilePath
forall a. Show a => a -> FilePath
show Ident
k

toParamType :: Term -> ParamType
toParamType :: Type -> ParamType
toParamType Type
t = case Type -> LinType
convType Type
t of
                  ParamType ParamType
pt -> ParamType
pt
                  LinType
_ -> FilePath -> ParamType
forall a. HasCallStack => FilePath -> a
error (FilePath -> ParamType) -> FilePath -> ParamType
forall a b. (a -> b) -> a -> b
$ FilePath
"toParamType: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Type -> FilePath
forall a. Show a => a -> FilePath
show Type
t

toParamId :: Term -> ParamId
toParamId :: Type -> ParamId
toParamId Type
t = case Type -> ParamType
toParamType Type
t of
                   ParamTypeId ParamId
p -> ParamId
p

paramType :: G.Grammar
             -> (ModuleName, Ident)
             -> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
paramType :: Grammar -> QIdent -> ((Set QIdent, Set QIdent), [ParamDef])
paramType Grammar
gr q :: QIdent
q@(ModuleName
_,Ident
n) =
    case Grammar -> QIdent -> Err (ModuleName, Info)
forall (m :: * -> *).
ErrorMonad m =>
Grammar -> QIdent -> m (ModuleName, Info)
lookupOrigInfo Grammar
gr QIdent
q of
      Ok (ModuleName
m,ResParam (Just (L Location
_ [Param]
ps)) Maybe [Type]
_)
       {- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
         ((QIdent -> Set QIdent
forall a. a -> Set a
S.singleton (ModuleName
m,Ident
n),[Param] -> Set QIdent
forall a a b. [(a, [(a, b, Type)])] -> Set QIdent
argTypes [Param]
ps),
          [ParamId -> [ParamValueDef] -> ParamDef
ParamDef ParamId
name ((Param -> ParamValueDef) -> [Param] -> [ParamValueDef]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> Param -> ParamValueDef
forall a b. ModuleName -> (Ident, [(a, b, Type)]) -> ParamValueDef
param ModuleName
m) [Param]
ps)]
         )
       where name :: ParamId
name = ModuleName -> Ident -> ParamId
forall i. QualIdent i => ModuleName -> Ident -> i
gQId ModuleName
m Ident
n
      Ok (ModuleName
m,ResOper  Maybe (L Type)
_ (Just (L Location
_ Type
t)))
        | ModuleName
mModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
==ModuleName
cPredef Bool -> Bool -> Bool
&& Ident
nIdent -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
==Ident
cInts ->
           ((Set QIdent
forall a. Set a
S.empty,Set QIdent
forall a. Set a
S.empty),[]) {-
           ((S.singleton (m,n),S.empty),
            [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
        | Bool
otherwise ->
           ((QIdent -> Set QIdent
forall a. a -> Set a
S.singleton (ModuleName
m,Ident
n),Grammar -> Type -> Set QIdent
paramTypes Grammar
gr Type
t),
            [ParamId -> LinType -> ParamDef
ParamAliasDef (ModuleName -> Ident -> ParamId
forall i. QualIdent i => ModuleName -> Ident -> i
gQId ModuleName
m Ident
n) (Type -> LinType
convType Type
t)])
      Err (ModuleName, Info)
_ -> ((Set QIdent
forall a. Set a
S.empty,Set QIdent
forall a. Set a
S.empty),[])
  where
    param :: ModuleName -> (Ident, [(a, b, Type)]) -> ParamValueDef
param ModuleName
m (Ident
n,[(a, b, Type)]
ctx) = ParamId -> [ParamId] -> ParamValueDef
forall arg. ParamId -> [arg] -> Param arg
Param (ModuleName -> Ident -> ParamId
forall i. QualIdent i => ModuleName -> Ident -> i
gQId ModuleName
m Ident
n) [Type -> ParamId
toParamId Type
t|(a
_,b
_,Type
t)<-[(a, b, Type)]
ctx]
    argTypes :: [(a, [(a, b, Type)])] -> Set QIdent
argTypes = [Set QIdent] -> Set QIdent
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set QIdent] -> Set QIdent)
-> ([(a, [(a, b, Type)])] -> [Set QIdent])
-> [(a, [(a, b, Type)])]
-> Set QIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, [(a, b, Type)]) -> Set QIdent)
-> [(a, [(a, b, Type)])] -> [Set QIdent]
forall a b. (a -> b) -> [a] -> [b]
map (a, [(a, b, Type)]) -> Set QIdent
forall a a b. (a, [(a, b, Type)]) -> Set QIdent
argTypes1
    argTypes1 :: (a, [(a, b, Type)]) -> Set QIdent
argTypes1 (a
n,[(a, b, Type)]
ctx) = [Set QIdent] -> Set QIdent
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions [Grammar -> Type -> Set QIdent
paramTypes Grammar
gr Type
t|(a
_,b
_,Type
t)<-[(a, b, Type)]
ctx]

lblId :: Label -> C.LabelId
lblId :: Label -> LabelId
lblId (LIdent Id
ri) = Id -> LabelId
LabelId Id
ri
lblId (LVar Int
i) = Id -> LabelId
LabelId (FilePath -> Id
rawIdentS (Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i)) -- hmm

modId :: ModuleName -> C.ModId
modId :: ModuleName -> ModId
modId (MN Ident
m) = Id -> ModId
ModId (Ident -> Id
ident2raw Ident
m)

class FromIdent i where
  gId :: Ident -> i

instance FromIdent VarId where
  gId :: Ident -> VarId
gId Ident
i = if Ident -> Bool
isWildIdent Ident
i then VarId
Anonymous else Id -> VarId
VarId (Ident -> Id
ident2raw Ident
i)

instance FromIdent C.FunId where gId :: Ident -> FunId
gId = Id -> FunId
C.FunId (Id -> FunId) -> (Ident -> Id) -> Ident -> FunId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Id
ident2raw
instance FromIdent CatId where gId :: Ident -> CatId
gId = Id -> CatId
CatId (Id -> CatId) -> (Ident -> Id) -> Ident -> CatId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Id
ident2raw
instance FromIdent ParamId where gId :: Ident -> ParamId
gId = QualId -> ParamId
ParamId (QualId -> ParamId) -> (Ident -> QualId) -> Ident -> ParamId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> QualId
unqual
instance FromIdent VarValueId where gId :: Ident -> VarValueId
gId = QualId -> VarValueId
VarValueId (QualId -> VarValueId) -> (Ident -> QualId) -> Ident -> VarValueId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> QualId
unqual

class FromIdent i => QualIdent i where
  gQId :: ModuleName -> Ident -> i

instance QualIdent ParamId where gQId :: ModuleName -> Ident -> ParamId
gQId ModuleName
m Ident
n = QualId -> ParamId
ParamId (ModuleName -> Ident -> QualId
qual ModuleName
m Ident
n)
instance QualIdent VarValueId where gQId :: ModuleName -> Ident -> VarValueId
gQId ModuleName
m Ident
n = QualId -> VarValueId
VarValueId (ModuleName -> Ident -> QualId
qual ModuleName
m Ident
n)

qual :: ModuleName -> Ident -> QualId
qual :: ModuleName -> Ident -> QualId
qual ModuleName
m Ident
n = ModId -> Id -> QualId
Qual (ModuleName -> ModId
modId ModuleName
m) (Ident -> Id
ident2raw Ident
n)

unqual :: Ident -> QualId
unqual :: Ident -> QualId
unqual Ident
n = Id -> QualId
Unqual (Ident -> Id
ident2raw Ident
n)

convFlags :: G.Grammar -> ModuleName -> Flags
convFlags :: Grammar -> ModuleName -> Flags
convFlags Grammar
gr ModuleName
mn =
  [(Id, FlagValue)] -> Flags
Flags [(FilePath -> Id
rawIdentS FilePath
n,Literal -> FlagValue
convLit Literal
v) |
         (FilePath
n,Literal
v)<-(FilePath -> [(FilePath, Literal)])
-> (ModuleInfo -> [(FilePath, Literal)])
-> Err ModuleInfo
-> [(FilePath, Literal)]
forall b a. (FilePath -> b) -> (a -> b) -> Err a -> b
err ([(FilePath, Literal)] -> FilePath -> [(FilePath, Literal)]
forall a b. a -> b -> a
const []) (Options -> [(FilePath, Literal)]
optionsPGF(Options -> [(FilePath, Literal)])
-> (ModuleInfo -> Options) -> ModuleInfo -> [(FilePath, Literal)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ModuleInfo -> Options
mflags) (Grammar -> ModuleName -> Err ModuleInfo
forall (m :: * -> *).
ErrorMonad m =>
Grammar -> ModuleName -> m ModuleInfo
lookupModule Grammar
gr ModuleName
mn)]
  where
    convLit :: Literal -> FlagValue
convLit Literal
l =
      case Literal
l of
        LStr FilePath
s -> FilePath -> FlagValue
Str FilePath
s
        LInt Int
i -> Int -> FlagValue
C.Int Int
i
        LFlt Double
d -> Double -> FlagValue
Flt Double
d