-- | Translate concrete syntax to Haskell
module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
import Data.List(isPrefixOf,sort,sortOn)
import qualified Data.Map as M
import qualified Data.Set as S
import GF.Text.Pretty
--import GF.Grammar.Predef(cPredef,cInts)
--import GF.Compile.Compute.Predef(predef)
--import GF.Compile.Compute.Value(Predefined(..))
import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
import GF.Infra.Option
import GF.Haskell as H
import GF.Grammar.Canonical as C
import GF.Compile.GrammarToCanonical
import Debug.Trace(trace)

-- | Generate Haskell code for the all concrete syntaxes associated with
-- the named abstract syntax in given the grammar.
concretes2haskell :: Options -> ModuleName -> Grammar -> [(FilePath, FilePath)]
concretes2haskell Options
opts ModuleName
absname Grammar
gr =
  [(FilePath
filename,Doc -> FilePath
forall a. Pretty a => a -> FilePath
render80 (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$ Options -> Abstract -> Concrete -> Doc
concrete2haskell Options
opts Abstract
abstr Concrete
cncmod)
     | let Grammar Abstract
abstr [Concrete]
cncs = Options -> ModuleName -> Grammar -> Grammar
grammar2canonical Options
opts ModuleName
absname Grammar
gr,
       Concrete
cncmod<-[Concrete]
cncs,
       let ModId Id
name = Concrete -> ModId
concName Concrete
cncmod
           filename :: FilePath
filename = Id -> FilePath
showRawIdent Id
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".hs" :: FilePath
  ]

-- | Generate Haskell code for the given concrete module.
-- The only options that make a difference are
-- @-haskell=noprefix@ and @-haskell=variants@.
concrete2haskell :: Options -> Abstract -> Concrete -> Doc
concrete2haskell Options
opts
                 abstr :: Abstract
abstr@(Abstract ModId
_ Flags
_ [CatDef]
cats [FunDef]
funs)
                 modinfo :: Concrete
modinfo@(Concrete ModId
cnc ModId
absname Flags
_ [ParamDef]
ps [LincatDef]
lcs [LinDef]
lns) =
  ModId -> ModId -> Doc
haskPreamble ModId
absname ModId
cnc Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
  [Dec] -> Doc
forall a. Pretty a => [a] -> Doc
vcat (
    Dec
nlDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:FilePath -> Dec
Comment FilePath
"--- Parameter types ---"Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:
    (ParamDef -> Dec) -> [ParamDef] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map ParamDef -> Dec
paramDef [ParamDef]
ps [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
    Dec
nlDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:FilePath -> Dec
Comment FilePath
"--- Type signatures for linearization functions ---"Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:
    (CatDef -> Dec) -> [CatDef] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map CatDef -> Dec
signature [CatDef]
cats [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
    Dec
nlDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:FilePath -> Dec
Comment FilePath
"--- Linearization functions for empty categories ---"Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:
    [Dec]
emptydefs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
    Dec
nlDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:FilePath -> Dec
Comment FilePath
"--- Linearization types ---"Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:
    (LincatDef -> Dec) -> [LincatDef] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map LincatDef -> Dec
lincatDef [LincatDef]
lcs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
    Dec
nlDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:FilePath -> Dec
Comment FilePath
"--- Linearization functions ---"Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:
    [Dec]
lindefs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
    Dec
nlDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:FilePath -> Dec
Comment FilePath
"--- Type classes for projection functions ---"Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:
    (LabelId -> Dec) -> [LabelId] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map LabelId -> Dec
labelClass (Set LabelId -> [LabelId]
forall a. Set a -> [a]
S.toList Set LabelId
labels) [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
    Dec
nlDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:FilePath -> Dec
Comment FilePath
"--- Record types ---"Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:
    ([LabelId] -> [Dec]) -> [[LabelId]] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [LabelId] -> [Dec]
recordType [[LabelId]]
recs)
  where
    nl :: Dec
nl = FilePath -> Dec
Comment FilePath
""
    recs :: [[LabelId]]
recs = Set [LabelId] -> [[LabelId]]
forall a. Set a -> [a]
S.toList (Set [LabelId] -> Set [LabelId] -> Set [LabelId]
forall a. Ord a => Set a -> Set a -> Set a
S.difference (([LincatDef], [LinDef]) -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records ([LincatDef]
lcs,[LinDef]
lns)) Set [LabelId]
common_records)

    labels :: Set LabelId
labels = Set LabelId -> Set LabelId -> Set LabelId
forall a. Ord a => Set a -> Set a -> Set a
S.difference ([Set LabelId] -> Set LabelId
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (([LabelId] -> Set LabelId) -> [[LabelId]] -> [Set LabelId]
forall a b. (a -> b) -> [a] -> [b]
map [LabelId] -> Set LabelId
forall a. Ord a => [a] -> Set a
S.fromList [[LabelId]]
recs)) Set LabelId
common_labels
    common_records :: Set [LabelId]
common_records = [[LabelId]] -> Set [LabelId]
forall a. Ord a => [a] -> Set a
S.fromList [[LabelId
label_s]]
    common_labels :: Set LabelId
common_labels = [LabelId] -> Set LabelId
forall a. Ord a => [a] -> Set a
S.fromList [LabelId
label_s]
    label_s :: LabelId
label_s = Id -> LabelId
LabelId (FilePath -> Id
rawIdentS FilePath
"s")

    signature :: CatDef -> Dec
signature (CatDef CatId
c [CatId]
_) = Ident -> Ty -> Dec
TypeSig Ident
lf (Ty -> Ty -> Ty
Fun Ty
abs (Ty -> Ty
pure Ty
lin))
      where
        abs :: Ty
abs = Ident -> Ty
tcon0 (FilePath -> Ident -> Ident
prefixIdent FilePath
"A." (CatId -> Ident
forall i. ToIdent i => i -> Ident
gId CatId
c))
        lin :: Ty
lin = Ident -> Ty
tcon0 Ident
lc
        lf :: Ident
lf = CatId -> Ident
linfunName CatId
c
        lc :: Ident
lc = CatId -> Ident
lincatName CatId
c

    emptydefs :: [Dec]
emptydefs = (CatId -> Dec) -> [CatId] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
map CatId -> Dec
emptydef (Set CatId -> [CatId]
forall a. Set a -> [a]
S.toList Set CatId
emptyCats)
    emptydef :: CatId -> Dec
emptydef CatId
c = Lhs -> Exp -> Dec
Eqn (CatId -> Ident
linfunName CatId
c,[Pat
WildP]) (FilePath -> Exp
Const FilePath
"undefined")

    emptyCats :: Set CatId
emptyCats = Set CatId
allcats Set CatId -> Set CatId -> Set CatId
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set CatId
linfuncats
      where
     --funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
       allcats :: Set CatId
allcats = [CatId] -> Set CatId
forall a. Ord a => [a] -> Set a
S.fromList [CatId
c | CatDef CatId
c [CatId]
_<-[CatDef]
cats]

    gId :: ToIdent i => i -> Ident
    gId :: i -> Ident
gId = (if Options -> HaskellOption -> Bool
haskellOption Options
opts HaskellOption
HaskellNoPrefix then Ident -> Ident
forall a. a -> a
id else FilePath -> Ident -> Ident
prefixIdent FilePath
"G")
          (Ident -> Ident) -> (i -> Ident) -> i -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> Ident
forall i. ToIdent i => i -> Ident
toIdent

    va :: Bool
va = Options -> HaskellOption -> Bool
haskellOption Options
opts HaskellOption
HaskellVariants
    pure :: Ty -> Ty
pure = if Bool
va then Ty -> Ty
ListT else Ty -> Ty
forall a. a -> a
id

    haskPreamble :: ModId -> ModId -> Doc
    haskPreamble :: ModId -> ModId -> Doc
haskPreamble ModId
absname ModId
cncname =
      FilePath
"{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" FilePath -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"module" FilePath -> ModId -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> ModId
cncname Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> FilePath
"where" Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"import Prelude hiding (Ordering(..))" Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"import Control.Applicative((<$>),(<*>))" Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"import PGF.Haskell" Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"import qualified" FilePath -> ModId -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> ModId
absname Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> FilePath
"as A" Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"" Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"--- Standard definitions ---" Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"linString (A.GString s) ="FilePath -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>FilePath -> Doc
pure FilePath
"R_s [TK s]" Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"linInt (A.GInt i) ="FilePath -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>FilePath -> Doc
pure FilePath
"R_s [TK (show i)]" Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"linFloat (A.GFloat x) ="FilePath -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>FilePath -> Doc
pure FilePath
"R_s [TK (show x)]" Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"" Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"----------------------------------------------------" Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"-- Automatic translation from GF to Haskell follows" Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$
      FilePath
"----------------------------------------------------"
      where
        pure :: FilePath -> Doc
pure = if Bool
va then FilePath -> Doc
forall a. Pretty a => a -> Doc
brackets else FilePath -> Doc
forall a. Pretty a => a -> Doc
pp

    paramDef :: ParamDef -> Dec
paramDef ParamDef
pd =
      case ParamDef
pd of
        ParamAliasDef ParamId
p LinType
t -> ConAp Ident -> Ty -> Dec
H.Type (Ident -> ConAp Ident
forall a. Ident -> ConAp a
conap0 (ParamId -> Ident
forall i. ToIdent i => i -> Ident
gId ParamId
p)) (LinType -> Ty
convLinType LinType
t)
        ParamDef ParamId
p [ParamValueDef]
pvs -> ConAp Ident -> [ConAp Ty] -> Deriving -> Dec
Data (Ident -> ConAp Ident
forall a. Ident -> ConAp a
conap0 (ParamId -> Ident
forall i. ToIdent i => i -> Ident
gId ParamId
p)) ((ParamValueDef -> ConAp Ty) -> [ParamValueDef] -> [ConAp Ty]
forall a b. (a -> b) -> [a] -> [b]
map ParamValueDef -> ConAp Ty
forall i. ToIdent i => Param i -> ConAp Ty
paramCon [ParamValueDef]
pvs) Deriving
derive
          where
            paramCon :: Param i -> ConAp Ty
paramCon (Param ParamId
c [i]
cs) = Ident -> [Ty] -> ConAp Ty
forall a. Ident -> [a] -> ConAp a
ConAp (ParamId -> Ident
forall i. ToIdent i => i -> Ident
gId ParamId
c) ((i -> Ty) -> [i] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map (Ident -> Ty
tcon0(Ident -> Ty) -> (i -> Ident) -> i -> Ty
forall b c a. (b -> c) -> (a -> b) -> a -> c
.i -> Ident
forall i. ToIdent i => i -> Ident
gId) [i]
cs)
            derive :: Deriving
derive = [FilePath
"Eq",FilePath
"Ord",FilePath
"Show"]

    convLinType :: LinType -> Ty
convLinType = LinType -> Ty
ppT
      where
        ppT :: LinType -> Ty
ppT LinType
t =
          case LinType
t of
            LinType
FloatType -> Ident -> Ty
tcon0 (FilePath -> Ident
identS FilePath
"Float")
            LinType
IntType -> Ident -> Ty
tcon0 (FilePath -> Ident
identS FilePath
"Int")
            ParamType (ParamTypeId ParamId
p) -> Ident -> Ty
tcon0 (ParamId -> Ident
forall i. ToIdent i => i -> Ident
gId ParamId
p)
            RecordType [RecordRowType]
rs -> Ident -> [Ty] -> Ty
forall (t :: * -> *). Foldable t => Ident -> t Ty -> Ty
tcon ([LabelId] -> Ident
rcon' [LabelId]
ls) ((LinType -> Ty) -> [LinType] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map LinType -> Ty
ppT [LinType]
ts)
              where ([LabelId]
ls,[LinType]
ts) = [(LabelId, LinType)] -> ([LabelId], [LinType])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(LabelId, LinType)] -> ([LabelId], [LinType]))
-> [(LabelId, LinType)] -> ([LabelId], [LinType])
forall a b. (a -> b) -> a -> b
$ ((LabelId, LinType) -> LabelId)
-> [(LabelId, LinType)] -> [(LabelId, LinType)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (LabelId, LinType) -> LabelId
forall a b. (a, b) -> a
fst [(LabelId
l,LinType
t)|RecordRow LabelId
l LinType
t<-[RecordRowType]
rs]
            LinType
StrType -> Ident -> Ty
tcon0 (FilePath -> Ident
identS FilePath
"Str")
            TableType LinType
pt LinType
lt -> Ty -> Ty -> Ty
Fun (LinType -> Ty
ppT LinType
pt) (LinType -> Ty
ppT LinType
lt)
--          TupleType lts ->

    lincatDef :: LincatDef -> Dec
lincatDef (LincatDef CatId
c LinType
t) = Ident -> Ty -> Dec
tsyn0 (CatId -> Ident
lincatName CatId
c) (LinType -> Ty
convLinType LinType
t)

    linfuncats :: Set CatId
linfuncats = [CatId] -> Set CatId
forall a. Ord a => [a] -> Set a
S.fromList [CatId]
linfuncatl
    ([CatId]
linfuncatl,[Dec]
lindefs) = [(CatId, Dec)] -> ([CatId], [Dec])
forall a b. [(a, b)] -> ([a], [b])
unzip ([LinDef] -> [(CatId, Dec)]
linDefs [LinDef]
lns)

    linDefs :: [LinDef] -> [(CatId, Dec)]
linDefs = ((CatId, (Ident, ([Pat], Exp))) -> (CatId, Dec))
-> [(CatId, (Ident, ([Pat], Exp)))] -> [(CatId, Dec)]
forall a b. (a -> b) -> [a] -> [b]
map (CatId, (Ident, ([Pat], Exp))) -> (CatId, Dec)
forall a. (a, (Ident, ([Pat], Exp))) -> (a, Dec)
eqn ([(CatId, (Ident, ([Pat], Exp)))] -> [(CatId, Dec)])
-> ([LinDef] -> [(CatId, (Ident, ([Pat], Exp)))])
-> [LinDef]
-> [(CatId, Dec)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CatId, (Ident, ([Pat], Exp))) -> CatId)
-> [(CatId, (Ident, ([Pat], Exp)))]
-> [(CatId, (Ident, ([Pat], Exp)))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (CatId, (Ident, ([Pat], Exp))) -> CatId
forall a b. (a, b) -> a
fst ([(CatId, (Ident, ([Pat], Exp)))]
 -> [(CatId, (Ident, ([Pat], Exp)))])
-> ([LinDef] -> [(CatId, (Ident, ([Pat], Exp)))])
-> [LinDef]
-> [(CatId, (Ident, ([Pat], Exp)))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LinDef -> (CatId, (Ident, ([Pat], Exp))))
-> [LinDef] -> [(CatId, (Ident, ([Pat], Exp)))]
forall a b. (a -> b) -> [a] -> [b]
map LinDef -> (CatId, (Ident, ([Pat], Exp)))
linDef
      where eqn :: (a, (Ident, ([Pat], Exp))) -> (a, Dec)
eqn (a
cat,(Ident
f,([Pat]
ps,Exp
rhs))) = (a
cat,Lhs -> Exp -> Dec
Eqn (Ident
f,[Pat]
ps) Exp
rhs)

    linDef :: LinDef -> (CatId, (Ident, ([Pat], Exp)))
linDef (LinDef FunId
f [VarId]
xs LinValue
rhs0) =
        (CatId
cat,(CatId -> Ident
linfunName CatId
cat,([Pat]
lhs,Exp
rhs)))
      where
        lhs :: [Pat]
lhs = [Ident -> [Pat] -> Pat
ConP (FunId -> Ident
forall i. ToIdent i => i -> Ident
aId FunId
f) ((Ident -> Pat) -> [Ident] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Pat
VarP [Ident]
abs_args)]
        aId :: i -> Ident
aId i
f = FilePath -> Ident -> Ident
prefixIdent FilePath
"A." (i -> Ident
forall i. ToIdent i => i -> Ident
gId i
f)

        [LinType
lincat] = [LinType
lincat | LincatDef CatId
c LinType
lincat<-[LincatDef]
lcs,CatId
cCatId -> CatId -> Bool
forall a. Eq a => a -> a -> Bool
==CatId
cat]
        [C.Type [TypeBinding]
absctx (TypeApp CatId
cat [Type]
_)] = [Type
t | FunDef FunId
f' Type
t<-[FunDef]
funs, FunId
f'FunId -> FunId -> Bool
forall a. Eq a => a -> a -> Bool
==FunId
f]

        abs_args :: [Ident]
abs_args = (Ident -> Ident) -> [Ident] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Ident
abs_arg [Ident]
args
        abs_arg :: Ident -> Ident
abs_arg = FilePath -> Ident -> Ident
prefixIdent FilePath
"abs_"
        args :: [Ident]
args = (VarId -> Ident) -> [VarId] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Ident -> Ident
prefixIdent FilePath
"g" (Ident -> Ident) -> (VarId -> Ident) -> VarId -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarId -> Ident
forall i. ToIdent i => i -> Ident
toIdent) [VarId]
xs

        rhs :: Exp
rhs = [(Ident, Exp)] -> Exp -> Exp
lets ((Ident -> TypeBinding -> (Ident, Exp))
-> [Ident] -> [TypeBinding] -> [(Ident, Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Ident -> TypeBinding -> (Ident, Exp)
letlin [Ident]
args [TypeBinding]
absctx)
                   ([(VarValueId, Ident)] -> LinValue -> Exp
convert [(VarValueId, Ident)]
vs ([(VarValueId, LinType)] -> LinType -> LinValue -> LinValue
coerce [(VarValueId, LinType)]
env LinType
lincat LinValue
rhs0))
          where
            vs :: [(VarValueId, Ident)]
vs = [(QualId -> VarValueId
VarValueId (Id -> QualId
Unqual Id
x),Ident
a)|(VarId Id
x,Ident
a)<-[VarId] -> [Ident] -> [(VarId, Ident)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VarId]
xs [Ident]
args]
            env :: [(VarValueId, LinType)]
env= [(QualId -> VarValueId
VarValueId (Id -> QualId
Unqual Id
x),LinType
lc)|(VarId Id
x,LinType
lc)<-[VarId] -> [LinType] -> [(VarId, LinType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [VarId]
xs ((TypeBinding -> LinType) -> [TypeBinding] -> [LinType]
forall a b. (a -> b) -> [a] -> [b]
map TypeBinding -> LinType
arglincat [TypeBinding]
absctx)]

        letlin :: Ident -> TypeBinding -> (Ident, Exp)
letlin Ident
a (TypeBinding VarId
_ (C.Type [TypeBinding]
_ (TypeApp CatId
acat [Type]
_))) =
          (Ident
a,Exp -> Exp -> Exp
Ap (Ident -> Exp
Var (CatId -> Ident
linfunName CatId
acat)) (Ident -> Exp
Var (Ident -> Ident
abs_arg Ident
a)))

        arglincat :: TypeBinding -> LinType
arglincat (TypeBinding VarId
_ (C.Type [TypeBinding]
_ (TypeApp CatId
acat [Type]
_))) = LinType
lincat
          where
            [LinType
lincat] = [LinType
lincat | LincatDef CatId
c LinType
lincat<-[LincatDef]
lcs,CatId
cCatId -> CatId -> Bool
forall a. Eq a => a -> a -> Bool
==CatId
acat]

    convert :: [(VarValueId, Ident)] -> LinValue -> Exp
convert = Bool -> [(VarValueId, Ident)] -> LinValue -> Exp
convert' Bool
va

    convert' :: Bool -> [(VarValueId, Ident)] -> LinValue -> Exp
convert' Bool
va [(VarValueId, Ident)]
vs = LinValue -> Exp
ppT
      where
        ppT0 :: LinValue -> Exp
ppT0 = Bool -> [(VarValueId, Ident)] -> LinValue -> Exp
convert' Bool
False [(VarValueId, Ident)]
vs
        ppTv :: [(VarValueId, Ident)] -> LinValue -> Exp
ppTv [(VarValueId, Ident)]
vs' = Bool -> [(VarValueId, Ident)] -> LinValue -> Exp
convert' Bool
va [(VarValueId, Ident)]
vs'

        pure :: Exp -> Exp
pure = if Bool
va then Exp -> Exp
single else Exp -> Exp
forall a. a -> a
id

        ppT :: LinValue -> Exp
ppT LinValue
t =
          case LinValue
t of
            TableValue LinType
ty [TableRowValue]
cs -> Exp -> Exp
pure ([TableRowValue] -> Exp
table [TableRowValue]
cs)
            Selection LinValue
t LinValue
p -> Exp -> Exp -> Exp
select (LinValue -> Exp
ppT LinValue
t) (LinValue -> Exp
ppT LinValue
p)
            ConcatValue LinValue
t1 LinValue
t2 -> Exp -> Exp -> Exp
concat (LinValue -> Exp
ppT LinValue
t1) (LinValue -> Exp
ppT LinValue
t2)
            RecordValue [RecordRowValue]
r -> Exp -> [Exp] -> Exp
aps ([LabelId] -> Exp
rcon [LabelId]
ls) ((LinValue -> Exp) -> [LinValue] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map LinValue -> Exp
ppT [LinValue]
ts)
              where ([LabelId]
ls,[LinValue]
ts) = [(LabelId, LinValue)] -> ([LabelId], [LinValue])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(LabelId, LinValue)] -> ([LabelId], [LinValue]))
-> [(LabelId, LinValue)] -> ([LabelId], [LinValue])
forall a b. (a -> b) -> a -> b
$ ((LabelId, LinValue) -> LabelId)
-> [(LabelId, LinValue)] -> [(LabelId, LinValue)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (LabelId, LinValue) -> LabelId
forall a b. (a, b) -> a
fst [(LabelId
l,LinValue
t)|RecordRow LabelId
l LinValue
t<-[RecordRowValue]
r]
            PredefValue PredefId
p -> Exp -> Exp
single (Ident -> Exp
Var (PredefId -> Ident
forall i. ToIdent i => i -> Ident
toIdent PredefId
p)) -- hmm
            Projection LinValue
t LabelId
l -> Exp -> Exp -> Exp
ap (LabelId -> Exp
proj LabelId
l) (LinValue -> Exp
ppT LinValue
t)
            VariantValue [] -> Exp
empty
            VariantValue ts :: [LinValue]
ts@(LinValue
_:[LinValue]
_) -> [LinValue] -> Exp
variants [LinValue]
ts
            VarValue VarValueId
x -> Exp -> (Ident -> Exp) -> Maybe Ident -> Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Ident -> Exp
Var (VarValueId -> Ident
forall i. ToIdent i => i -> Ident
gId VarValueId
x)) (Exp -> Exp
pure (Exp -> Exp) -> (Ident -> Exp) -> Ident -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Exp
Var) (Maybe Ident -> Exp) -> Maybe Ident -> Exp
forall a b. (a -> b) -> a -> b
$ VarValueId -> [(VarValueId, Ident)] -> Maybe Ident
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup VarValueId
x [(VarValueId, Ident)]
vs
            PreValue [(Deriving, LinValue)]
vs LinValue
t' -> Exp -> Exp
pure (LinValue -> [(Deriving, LinValue)] -> Exp
forall a. Show a => LinValue -> [([a], LinValue)] -> Exp
alts LinValue
t' [(Deriving, LinValue)]
vs)
            ParamConstant (Param ParamId
c [LinValue]
vs) -> Exp -> [Exp] -> Exp
aps (Ident -> Exp
Var (ParamId -> Ident
pId ParamId
c)) ((LinValue -> Exp) -> [LinValue] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map LinValue -> Exp
ppT [LinValue]
vs)
            ErrorValue FilePath
s -> Exp -> Exp -> Exp
ap (FilePath -> Exp
Const FilePath
"error") (FilePath -> Exp
Const (FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
s)) -- !!
            LiteralValue LinLiteral
l -> LinLiteral -> Exp
ppL LinLiteral
l
            LinValue
_ -> FilePath -> Exp
forall a. HasCallStack => FilePath -> a
error (FilePath
"convert "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++LinValue -> FilePath
forall a. Show a => a -> FilePath
show LinValue
t)

        ppL :: LinLiteral -> Exp
ppL LinLiteral
l =
          case LinLiteral
l of
            FloatConstant Float
x -> Exp -> Exp
pure (Float -> Exp
forall a. Show a => a -> Exp
lit Float
x)
            IntConstant Int
n -> Exp -> Exp
pure (Int -> Exp
forall a. Show a => a -> Exp
lit Int
n)
            StrConstant FilePath
s -> Exp -> Exp
pure (FilePath -> Exp
forall a. Show a => a -> Exp
token FilePath
s)

        pId :: ParamId -> Ident
pId p :: ParamId
p@(ParamId QualId
s) =
          if FilePath
"to_R_" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` QualId -> FilePath
unqual QualId
s then ParamId -> Ident
forall i. ToIdent i => i -> Ident
toIdent ParamId
p else ParamId -> Ident
forall i. ToIdent i => i -> Ident
gId ParamId
p -- !! a hack

        table :: [TableRowValue] -> Exp
table [TableRowValue]
cs =
            if (LinPattern -> Bool) -> [LinPattern] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Any] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null([Any] -> Bool) -> (LinPattern -> [Any]) -> LinPattern -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.LinPattern -> [Any]
forall p a. p -> [a]
patVars) [LinPattern]
ps
            then [(Ident, Exp)] -> Exp -> Exp
lets [(Ident, Exp)]
ds ([(Pat, Exp)] -> Exp
LambdaCase [(LinPattern -> Pat
ppP LinPattern
p,Exp
t')|(LinPattern
p,Exp
t')<-[LinPattern] -> [Exp] -> [(LinPattern, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LinPattern]
ps [Exp]
ts'])
            else [(Pat, Exp)] -> Exp
LambdaCase ((TableRowValue -> (Pat, Exp)) -> [TableRowValue] -> [(Pat, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map TableRowValue -> (Pat, Exp)
ppCase [TableRowValue]
cs)
          where
            ([(Ident, Exp)]
ds,[Exp]
ts') = [LinValue] -> ([(Ident, Exp)], [Exp])
dedup [LinValue]
ts
            ([LinPattern]
ps,[LinValue]
ts) = [(LinPattern, LinValue)] -> ([LinPattern], [LinValue])
forall a b. [(a, b)] -> ([a], [b])
unzip [(LinPattern
p,LinValue
t)|TableRow LinPattern
p LinValue
t<-[TableRowValue]
cs]
        ppCase :: TableRowValue -> (Pat, Exp)
ppCase (TableRow LinPattern
p LinValue
t) = (LinPattern -> Pat
ppP LinPattern
p,[(VarValueId, Ident)] -> LinValue -> Exp
ppTv (LinPattern -> [(VarValueId, Ident)]
forall p a. p -> [a]
patVars LinPattern
p[(VarValueId, Ident)]
-> [(VarValueId, Ident)] -> [(VarValueId, Ident)]
forall a. [a] -> [a] -> [a]
++[(VarValueId, Ident)]
vs) LinValue
t)
{-
        ppPredef n =
          case predef n of
            Ok BIND       -> single (c "BIND")
            Ok SOFT_BIND  -> single (c "SOFT_BIND")
            Ok SOFT_SPACE -> single (c "SOFT_SPACE")
            Ok CAPIT      -> single (c "CAPIT")
            Ok ALL_CAPIT  -> single (c "ALL_CAPIT")
            _ -> Var n
-}
        ppP :: LinPattern -> Pat
ppP LinPattern
p =
          case LinPattern
p of
            ParamPattern (Param ParamId
c [LinPattern]
ps) -> Ident -> [Pat] -> Pat
ConP (ParamId -> Ident
forall i. ToIdent i => i -> Ident
gId ParamId
c) ((LinPattern -> Pat) -> [LinPattern] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map LinPattern -> Pat
ppP [LinPattern]
ps)
            RecordPattern [RecordRow LinPattern]
r -> Ident -> [Pat] -> Pat
ConP ([LabelId] -> Ident
rcon' [LabelId]
ls) ((LinPattern -> Pat) -> [LinPattern] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map LinPattern -> Pat
ppP [LinPattern]
ps)
              where ([LabelId]
ls,[LinPattern]
ps) = [(LabelId, LinPattern)] -> ([LabelId], [LinPattern])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(LabelId, LinPattern)] -> ([LabelId], [LinPattern]))
-> [(LabelId, LinPattern)] -> ([LabelId], [LinPattern])
forall a b. (a -> b) -> a -> b
$ ((LabelId, LinPattern) -> LabelId)
-> [(LabelId, LinPattern)] -> [(LabelId, LinPattern)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (LabelId, LinPattern) -> LabelId
forall a b. (a, b) -> a
fst [(LabelId
l,LinPattern
p)|RecordRow LabelId
l LinPattern
p<-[RecordRow LinPattern]
r]
            LinPattern
WildPattern -> Pat
WildP

        token :: a -> Exp
token a
s = Exp -> Exp
single (FilePath -> Exp
c FilePath
"TK" Exp -> Exp -> Exp
`Ap` a -> Exp
forall a. Show a => a -> Exp
lit a
s)

        alts :: LinValue -> [([a], LinValue)] -> Exp
alts LinValue
t' [([a], LinValue)]
vs = Exp -> Exp
single (FilePath -> Exp
c FilePath
"TP" Exp -> Exp -> Exp
`Ap` [Exp] -> Exp
List ((([a], LinValue) -> Exp) -> [([a], LinValue)] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map ([a], LinValue) -> Exp
forall a. Show a => ([a], LinValue) -> Exp
alt [([a], LinValue)]
vs) Exp -> Exp -> Exp
`Ap` LinValue -> Exp
ppT0 LinValue
t')
          where
            alt :: ([a], LinValue) -> Exp
alt ([a]
s,LinValue
t) = Exp -> Exp -> Exp
Pair ([Exp] -> Exp
List ([a] -> [Exp]
forall a. Show a => [a] -> [Exp]
pre [a]
s)) (LinValue -> Exp
ppT0 LinValue
t)
            pre :: [a] -> [Exp]
pre [a]
s = (a -> Exp) -> [a] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map a -> Exp
forall a. Show a => a -> Exp
lit [a]
s

        c :: FilePath -> Exp
c = FilePath -> Exp
Const
        lit :: a -> Exp
lit a
s = FilePath -> Exp
c (a -> FilePath
forall a. Show a => a -> FilePath
show a
s) -- hmm
        concat :: Exp -> Exp -> Exp
concat = if Bool
va then Exp -> Exp -> Exp
concat' else Exp -> Exp -> Exp
plusplus
          where
            concat' :: Exp -> Exp -> Exp
concat' (List [List [Exp]
ts1]) (List [List [Exp]
ts2]) = [Exp] -> Exp
List [[Exp] -> Exp
List ([Exp]
ts1[Exp] -> [Exp] -> [Exp]
forall a. [a] -> [a] -> [a]
++[Exp]
ts2)]
            concat' Exp
t1 Exp
t2 = Exp -> FilePath -> Exp -> Exp
Op Exp
t1 FilePath
"+++" Exp
t2

        pure' :: Exp -> Exp
pure' = Exp -> Exp
single -- forcing the list monad

        select :: Exp -> Exp -> Exp
select = if Bool
va then Exp -> Exp -> Exp
select' else Exp -> Exp -> Exp
Ap
        select' :: Exp -> Exp -> Exp
select' (List [Exp
t]) (List [Exp
p]) = Exp -> FilePath -> Exp -> Exp
Op Exp
t FilePath
"!" Exp
p
        select' (List [Exp
t]) Exp
p = Exp -> FilePath -> Exp -> Exp
Op Exp
t FilePath
"!$" Exp
p
        select' Exp
t Exp
p = Exp -> FilePath -> Exp -> Exp
Op Exp
t FilePath
"!*" Exp
p

        ap :: Exp -> Exp -> Exp
ap = if Bool
va then Exp -> Exp -> Exp
ap' else Exp -> Exp -> Exp
Ap
          where
            ap' :: Exp -> Exp -> Exp
ap' (List [Exp
f]) Exp
x = Exp -> Exp -> Exp
fmap Exp
f Exp
x
            ap' Exp
f Exp
x = Exp -> FilePath -> Exp -> Exp
Op Exp
f FilePath
"<*>" Exp
x
            fmap :: Exp -> Exp -> Exp
fmap Exp
f (List [Exp
x]) = Exp -> Exp
pure' (Exp -> Exp -> Exp
Ap Exp
f Exp
x)
            fmap Exp
f Exp
x = Exp -> FilePath -> Exp -> Exp
Op Exp
f FilePath
"<$>" Exp
x

    --  join = if va then join' else id
        join' :: Exp -> Exp
join' (List [Exp
x]) = Exp
x
        join' Exp
x = FilePath -> Exp
c FilePath
"concat" Exp -> Exp -> Exp
`Ap` Exp
x

        empty :: Exp
empty = if Bool
va then [Exp] -> Exp
List [] else FilePath -> Exp
c FilePath
"error" Exp -> Exp -> Exp
`Ap` FilePath -> Exp
c (FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
"empty variant")
        variants :: [LinValue] -> Exp
variants = if Bool
va then \ [LinValue]
ts -> Exp -> Exp
join' ([Exp] -> Exp
List ((LinValue -> Exp) -> [LinValue] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map LinValue -> Exp
ppT [LinValue]
ts))
                         else \ (LinValue
t:[LinValue]
_) -> LinValue -> Exp
ppT LinValue
t

        aps :: Exp -> [Exp] -> Exp
aps Exp
f [] = Exp
f
        aps Exp
f (Exp
a:[Exp]
as) = Exp -> [Exp] -> Exp
aps (Exp -> Exp -> Exp
ap Exp
f Exp
a) [Exp]
as

        dedup :: [LinValue] -> ([(Ident, Exp)], [Exp])
dedup [LinValue]
ts =
            if Map Int Int -> Bool
forall k a. Map k a -> Bool
M.null Map Int Int
dups
            then ([],(LinValue -> Exp) -> [LinValue] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map LinValue -> Exp
ppT [LinValue]
ts)
            else ([(Int -> Ident
forall a. Show a => a -> Ident
ev Int
i,LinValue -> Exp
ppT LinValue
t)|(Int
i,LinValue
t)<-[(Int, LinValue)]
defs],(LinValue -> Int -> Exp) -> [LinValue] -> [Int] -> [Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith LinValue -> Int -> Exp
entry [LinValue]
ts [Int]
is)
          where
            entry :: LinValue -> Int -> Exp
entry LinValue
t Int
i = Exp -> (Int -> Exp) -> Maybe Int -> Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (LinValue -> Exp
ppT LinValue
t) (Ident -> Exp
Var (Ident -> Exp) -> (Int -> Ident) -> Int -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Ident
forall a. Show a => a -> Ident
ev) (Int -> Map Int Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
i Map Int Int
dups)
            ev :: a -> Ident
ev a
i = FilePath -> Ident
identS (FilePath
"e'"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++a -> FilePath
forall a. Show a => a -> FilePath
show a
i)

            defs :: [(Int, LinValue)]
defs = [(Int
i1,LinValue
t)|(LinValue
t,Int
i1:Int
_:[Int]
_)<-[(LinValue, [Int])]
ms]
            dups :: Map Int Int
dups = [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int
i2,Int
i1)|(LinValue
_,Int
i1:is :: [Int]
is@(Int
_:[Int]
_))<-[(LinValue, [Int])]
ms,Int
i2<-Int
i1Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
is]
            ms :: [(LinValue, [Int])]
ms = Map LinValue [Int] -> [(LinValue, [Int])]
forall k a. Map k a -> [(k, a)]
M.toList Map LinValue [Int]
m
            m :: Map LinValue [Int]
m = ([Int] -> [Int]) -> Map LinValue [Int] -> Map LinValue [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> [Int]
forall a. Ord a => [a] -> [a]
sort (([Int] -> [Int] -> [Int])
-> [(LinValue, [Int])] -> Map LinValue [Int]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
(++) ([LinValue] -> [[Int]] -> [(LinValue, [Int])]
forall a b. [a] -> [b] -> [(a, b)]
zip [LinValue]
ts [[Int
i]|Int
i<-[Int]
is]))
            is :: [Int]
is = [Int
0..]::[Int]


--con = Cn . identS

class Records t where
  records :: t -> S.Set [LabelId]

instance Records t => Records [t] where
  records :: [t] -> Set [LabelId]
records = [Set [LabelId]] -> Set [LabelId]
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set [LabelId]] -> Set [LabelId])
-> ([t] -> [Set [LabelId]]) -> [t] -> Set [LabelId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> Set [LabelId]) -> [t] -> [Set [LabelId]]
forall a b. (a -> b) -> [a] -> [b]
map t -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records

instance (Records t1,Records t2) => Records (t1,t2) where
  records :: (t1, t2) -> Set [LabelId]
records (t1
t1,t2
t2) = Set [LabelId] -> Set [LabelId] -> Set [LabelId]
forall a. Ord a => Set a -> Set a -> Set a
S.union (t1 -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records t1
t1) (t2 -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records t2
t2)

instance Records LincatDef where
  records :: LincatDef -> Set [LabelId]
records (LincatDef CatId
_ LinType
lt) = LinType -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records LinType
lt

instance Records LinDef where
  records :: LinDef -> Set [LabelId]
records (LinDef FunId
_ [VarId]
_ LinValue
lv) = LinValue -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records LinValue
lv

instance Records LinType where
  records :: LinType -> Set [LabelId]
records LinType
t =
    case LinType
t of
      RecordType [RecordRowType]
r -> [RecordRowType] -> Set [LabelId]
forall b. Records b => [RecordRow b] -> Set [LabelId]
rowRecords [RecordRowType]
r
      TableType LinType
pt LinType
lt -> (LinType, LinType) -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records (LinType
pt,LinType
lt)
      TupleType [LinType]
ts -> [LinType] -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records [LinType]
ts
      LinType
_ -> Set [LabelId]
forall a. Set a
S.empty

rowRecords :: [RecordRow b] -> Set [LabelId]
rowRecords [RecordRow b]
r = [LabelId] -> Set [LabelId] -> Set [LabelId]
forall a. Ord a => a -> Set a -> Set a
S.insert ([LabelId] -> [LabelId]
forall a. Ord a => [a] -> [a]
sort [LabelId]
ls) ([b] -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records [b]
ts)
  where ([LabelId]
ls,[b]
ts) = [(LabelId, b)] -> ([LabelId], [b])
forall a b. [(a, b)] -> ([a], [b])
unzip [(LabelId
l,b
t)|RecordRow LabelId
l b
t<-[RecordRow b]
r]

instance Records LinValue where
  records :: LinValue -> Set [LabelId]
records LinValue
v =
    case LinValue
v of
      ConcatValue LinValue
v1 LinValue
v2 -> (LinValue, LinValue) -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records (LinValue
v1,LinValue
v2)
      ParamConstant (Param ParamId
c [LinValue]
vs) -> [LinValue] -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records [LinValue]
vs
      RecordValue [RecordRowValue]
r -> [RecordRowValue] -> Set [LabelId]
forall b. Records b => [RecordRow b] -> Set [LabelId]
rowRecords [RecordRowValue]
r
      TableValue LinType
t [TableRowValue]
r -> (LinType, [TableRowValue]) -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records (LinType
t,[TableRowValue]
r)
      TupleValue [LinValue]
vs -> [LinValue] -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records [LinValue]
vs
      VariantValue [LinValue]
vs -> [LinValue] -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records [LinValue]
vs
      PreValue [(Deriving, LinValue)]
alts LinValue
d -> ([LinValue], LinValue) -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records (((Deriving, LinValue) -> LinValue)
-> [(Deriving, LinValue)] -> [LinValue]
forall a b. (a -> b) -> [a] -> [b]
map (Deriving, LinValue) -> LinValue
forall a b. (a, b) -> b
snd [(Deriving, LinValue)]
alts,LinValue
d)
      Projection LinValue
v LabelId
l -> LinValue -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records LinValue
v
      Selection LinValue
v1 LinValue
v2 -> (LinValue, LinValue) -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records (LinValue
v1,LinValue
v2)
      LinValue
_ -> Set [LabelId]
forall a. Set a
S.empty

instance Records rhs => Records (TableRow rhs) where
  records :: TableRow rhs -> Set [LabelId]
records (TableRow LinPattern
_ rhs
v) = rhs -> Set [LabelId]
forall t. Records t => t -> Set [LabelId]
records rhs
v


-- | Record subtyping is converted into explicit coercions in Haskell
coerce :: [(VarValueId, LinType)] -> LinType -> LinValue -> LinValue
coerce [(VarValueId, LinType)]
env LinType
ty LinValue
t =
  case (LinType
ty,LinValue
t) of
    (LinType
_,VariantValue [LinValue]
ts) -> [LinValue] -> LinValue
VariantValue ((LinValue -> LinValue) -> [LinValue] -> [LinValue]
forall a b. (a -> b) -> [a] -> [b]
map ([(VarValueId, LinType)] -> LinType -> LinValue -> LinValue
coerce [(VarValueId, LinType)]
env LinType
ty) [LinValue]
ts)
    (TableType LinType
ti LinType
tv,TableValue LinType
_ [TableRowValue]
cs) ->
      LinType -> [TableRowValue] -> LinValue
TableValue LinType
ti [LinPattern -> LinValue -> TableRowValue
forall rhs. LinPattern -> rhs -> TableRow rhs
TableRow LinPattern
p ([(VarValueId, LinType)] -> LinType -> LinValue -> LinValue
coerce [(VarValueId, LinType)]
env LinType
tv LinValue
t)|TableRow LinPattern
p LinValue
t<-[TableRowValue]
cs]
    (RecordType [RecordRowType]
rt,RecordValue [RecordRowValue]
r) ->
      [RecordRowValue] -> LinValue
RecordValue [LabelId -> LinValue -> RecordRowValue
forall rhs. LabelId -> rhs -> RecordRow rhs
RecordRow LabelId
l ([(VarValueId, LinType)] -> LinType -> LinValue -> LinValue
coerce [(VarValueId, LinType)]
env LinType
ft LinValue
f) |
                     RecordRow LabelId
l LinValue
f<-[RecordRowValue]
r,LinType
ft<-[LinType
ft | RecordRow LabelId
l' LinType
ft <- [RecordRowType]
rt, LabelId
l'LabelId -> LabelId -> Bool
forall a. Eq a => a -> a -> Bool
==LabelId
l]]
    (RecordType [RecordRowType]
rt,VarValue VarValueId
x)->
      case VarValueId -> [(VarValueId, LinType)] -> Maybe LinType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup VarValueId
x [(VarValueId, LinType)]
env of
        Just LinType
ty' | LinType
ty'LinType -> LinType -> Bool
forall a. Eq a => a -> a -> Bool
/=LinType
ty -> -- better to compare to normal form of ty'
                            --trace ("coerce "++render ty'++" to "++render ty) $
                            ParamId -> [LinValue] -> LinValue
app ([RecordRowType] -> ParamId
forall rhs. [RecordRow rhs] -> ParamId
to_rcon [RecordRowType]
rt) [LinValue
t]
                 | Bool
otherwise -> LinValue
t -- types match, no coercion needed
        Maybe LinType
_ -> FilePath -> LinValue -> LinValue
forall a. FilePath -> a -> a
trace (Doc -> FilePath
forall a. Pretty a => a -> FilePath
render (FilePath
"missing type to coerce"FilePath -> VarValueId -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>VarValueId
xDoc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>FilePath
"to"Doc -> FilePath -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+>LinType -> FilePath
forall a. Pretty a => a -> FilePath
render LinType
ty
                            Doc -> Doc -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
$$ FilePath
"in" FilePath -> [VarValueId] -> Doc
forall a1 a2. (Pretty a1, Pretty a2) => a1 -> a2 -> Doc
<+> ((VarValueId, LinType) -> VarValueId)
-> [(VarValueId, LinType)] -> [VarValueId]
forall a b. (a -> b) -> [a] -> [b]
map (VarValueId, LinType) -> VarValueId
forall a b. (a, b) -> a
fst [(VarValueId, LinType)]
env))
                   LinValue
t
    (LinType, LinValue)
_ -> LinValue
t
  where
    app :: ParamId -> [LinValue] -> LinValue
app ParamId
f [LinValue]
ts = Param LinValue -> LinValue
ParamConstant (ParamId -> [LinValue] -> Param LinValue
forall arg. ParamId -> [arg] -> Param arg
Param ParamId
f [LinValue]
ts) -- !! a hack
    to_rcon :: [RecordRow rhs] -> ParamId
to_rcon = QualId -> ParamId
ParamId (QualId -> ParamId)
-> ([RecordRow rhs] -> QualId) -> [RecordRow rhs] -> ParamId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> QualId
Unqual (Id -> QualId)
-> ([RecordRow rhs] -> Id) -> [RecordRow rhs] -> QualId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Id
rawIdentS (FilePath -> Id)
-> ([RecordRow rhs] -> FilePath) -> [RecordRow rhs] -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabelId] -> FilePath
to_rcon' ([LabelId] -> FilePath)
-> ([RecordRow rhs] -> [LabelId]) -> [RecordRow rhs] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RecordRow rhs] -> [LabelId]
forall rhs. [RecordRow rhs] -> [LabelId]
labels

patVars :: p -> [a]
patVars p
p = []

labels :: [RecordRow rhs] -> [LabelId]
labels [RecordRow rhs]
r = [LabelId
l | RecordRow LabelId
l rhs
_ <- [RecordRow rhs]
r]

proj :: LabelId -> Exp
proj = Ident -> Exp
Var (Ident -> Exp) -> (LabelId -> Ident) -> LabelId -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Ident
identS (FilePath -> Ident) -> (LabelId -> FilePath) -> LabelId -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelId -> FilePath
proj'
proj' :: LabelId -> FilePath
proj' (LabelId Id
l) = FilePath
"proj_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Id -> FilePath
showRawIdent Id
l
rcon :: [LabelId] -> Exp
rcon = Ident -> Exp
Var (Ident -> Exp) -> ([LabelId] -> Ident) -> [LabelId] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabelId] -> Ident
rcon'
rcon' :: [LabelId] -> Ident
rcon' = FilePath -> Ident
identS (FilePath -> Ident)
-> ([LabelId] -> FilePath) -> [LabelId] -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabelId] -> FilePath
rcon_name
rcon_name :: [LabelId] -> FilePath
rcon_name [LabelId]
ls = FilePath
"R"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++Deriving -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Deriving -> Deriving
forall a. Ord a => [a] -> [a]
sort [Char
'_'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Id -> FilePath
showRawIdent Id
l | LabelId Id
l <- [LabelId]
ls])
to_rcon' :: [LabelId] -> FilePath
to_rcon' = (FilePath
"to_"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> ([LabelId] -> FilePath) -> [LabelId] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LabelId] -> FilePath
rcon_name

recordType :: [LabelId] -> [Dec]
recordType [LabelId]
ls =
    ConAp Ident -> [ConAp Ty] -> Deriving -> Dec
Data ConAp Ident
lhs [ConAp Ty
app] [FilePath
"Eq",FilePath
"Ord",FilePath
"Show"]Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:
    Dec
enumAllInstanceDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:
    (Ident -> LabelId -> Dec) -> [Ident] -> [LabelId] -> [Dec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Ident -> LabelId -> Dec
projection [Ident]
vs [LabelId]
ls [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++
    [Lhs -> Exp -> Dec
Eqn (FilePath -> Ident
identS ([LabelId] -> FilePath
to_rcon' [LabelId]
ls),[Ident -> Pat
VarP Ident
r])
         ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
Ap (Ident -> Exp
Var Ident
cn) [Ident -> Exp
Var (FilePath -> Ident
identS (LabelId -> FilePath
proj' LabelId
l)) Exp -> Exp -> Exp
`Ap` Ident -> Exp
Var Ident
r|LabelId
l<-[LabelId]
ls])]
  where
    r :: Ident
r = FilePath -> Ident
identS FilePath
"r"
    cn :: Ident
cn = [LabelId] -> Ident
rcon' [LabelId]
ls
 -- Not all record labels are syntactically correct as type variables in Haskell
 -- app = cn<+>ls
    lhs :: ConAp Ident
lhs = Ident -> [Ident] -> ConAp Ident
forall a. Ident -> [a] -> ConAp a
ConAp Ident
cn [Ident]
vs -- don't reuse record labels
    app :: ConAp Ty
app = (Ident -> Ty) -> ConAp Ident -> ConAp Ty
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Ident -> Ty
TId ConAp Ident
lhs
    tapp :: Ty
tapp = (Ty -> Ty -> Ty) -> Ty -> [Ty] -> Ty
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Ty -> Ty -> Ty
TAp (Ident -> Ty
TId Ident
cn) ((Ident -> Ty) -> [Ident] -> [Ty]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Ty
TId [Ident]
vs)
    vs :: [Ident]
vs = [FilePath -> Ident
identS (Char
't'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i)|Int
i<-[Int
1..Int
n]]
    n :: Int
n = [LabelId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LabelId]
ls

    projection :: Ident -> LabelId -> Dec
projection Ident
v LabelId
l = [Ty] -> Ty -> [(Lhs, Exp)] -> Dec
Instance [] (Ident -> Ty
TId Ident
name Ty -> Ty -> Ty
`TAp` Ty
tapp Ty -> Ty -> Ty
`TAp` Ident -> Ty
TId Ident
v)
                              [((Ident
prj,[Pat
papp]),Ident -> Exp
Var Ident
v)]
     where
       name :: Ident
name = FilePath -> Ident
identS (FilePath
"Has_"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++LabelId -> FilePath
forall a. Pretty a => a -> FilePath
render LabelId
l)
       prj :: Ident
prj = FilePath -> Ident
identS (LabelId -> FilePath
proj' LabelId
l)
       papp :: Pat
papp = Ident -> [Pat] -> Pat
ConP Ident
cn ((Ident -> Pat) -> [Ident] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> Pat
VarP [Ident]
vs)

    enumAllInstance :: Dec
enumAllInstance =
       [Ty] -> Ty -> [(Lhs, Exp)] -> Dec
Instance [Ty]
ctx (Ty
tEnumAll Ty -> Ty -> Ty
`TAp` Ty
tapp)[(FilePath -> Lhs
forall a. FilePath -> (Ident, [a])
lhs0 FilePath
"enumAll",Ident -> Int -> Exp
enumCon Ident
cn Int
n)]
      where
        ctx :: [Ty]
ctx =  [Ty
tEnumAll Ty -> Ty -> Ty
`TAp` Ident -> Ty
TId Ident
v|Ident
v<-[Ident]
vs]
        tEnumAll :: Ty
tEnumAll = Ident -> Ty
TId (FilePath -> Ident
identS FilePath
"EnumAll")

labelClass :: LabelId -> Dec
labelClass LabelId
l =
    [ConAp Ident] -> ConAp Ident -> FunDeps -> [(Ident, Ty)] -> Dec
Class [] (Ident -> [Ident] -> ConAp Ident
forall a. Ident -> [a] -> ConAp a
ConAp Ident
name [Ident
r,Ident
a]) [([Ident
r],[Ident
a])]
          [(FilePath -> Ident
identS (LabelId -> FilePath
proj' LabelId
l),Ident -> Ty
TId Ident
r Ty -> Ty -> Ty
`Fun` Ident -> Ty
TId Ident
a)]
  where
    name :: Ident
name = FilePath -> Ident
identS (FilePath
"Has_"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++LabelId -> FilePath
forall a. Pretty a => a -> FilePath
render LabelId
l)
    r :: Ident
r = FilePath -> Ident
identS FilePath
"r"
    a :: Ident
a = FilePath -> Ident
identS FilePath
"a"

enumCon :: Ident -> Int -> Exp
enumCon Ident
name Int
arity =
    if Int
arityInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0
    then Exp -> Exp
single (Ident -> Exp
Var Ident
name)
    else (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
ap (Exp -> Exp
single (Ident -> Exp
Var Ident
name)) (Int -> Exp -> [Exp]
forall a. Int -> a -> [a]
replicate Int
arity (FilePath -> Exp
Const FilePath
"enumAll"))
  where
    ap :: Exp -> Exp -> Exp
ap (List [Exp
f]) Exp
a = Exp -> FilePath -> Exp -> Exp
Op Exp
f FilePath
"<$>" Exp
a
    ap Exp
f Exp
a = Exp -> FilePath -> Exp -> Exp
Op Exp
f FilePath
"<*>" Exp
a

lincatName,linfunName :: CatId -> Ident
lincatName :: CatId -> Ident
lincatName CatId
c = FilePath -> Ident -> Ident
prefixIdent FilePath
"Lin" (CatId -> Ident
forall i. ToIdent i => i -> Ident
toIdent CatId
c)
linfunName :: CatId -> Ident
linfunName CatId
c = FilePath -> Ident -> Ident
prefixIdent FilePath
"lin" (CatId -> Ident
forall i. ToIdent i => i -> Ident
toIdent CatId
c)

class ToIdent i where toIdent :: i -> Ident

instance ToIdent ParamId where toIdent :: ParamId -> Ident
toIdent (ParamId QualId
q) = QualId -> Ident
qIdentC QualId
q
instance ToIdent PredefId where toIdent :: PredefId -> Ident
toIdent (PredefId Id
s) = Id -> Ident
identC Id
s
instance ToIdent CatId   where toIdent :: CatId -> Ident
toIdent (CatId Id
s) = Id -> Ident
identC Id
s
instance ToIdent C.FunId where toIdent :: FunId -> Ident
toIdent (FunId Id
s) = Id -> Ident
identC Id
s
instance ToIdent VarValueId where toIdent :: VarValueId -> Ident
toIdent (VarValueId QualId
q) = QualId -> Ident
qIdentC QualId
q

qIdentC :: QualId -> Ident
qIdentC = FilePath -> Ident
identS (FilePath -> Ident) -> (QualId -> FilePath) -> QualId -> Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualId -> FilePath
unqual

unqual :: QualId -> FilePath
unqual (Qual (ModId Id
m) Id
n) = Id -> FilePath
showRawIdent Id
mFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"_"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Id -> FilePath
showRawIdent Id
n
unqual (Unqual Id
n) = Id -> FilePath
showRawIdent Id
n

instance ToIdent VarId where
  toIdent :: VarId -> Ident
toIdent VarId
Anonymous = Ident
identW
  toIdent (VarId Id
s) = Id -> Ident
identC Id
s