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 opts absname gr =
[(filename,render80 $ concrete2haskell opts abstr cncmod)
| let Grammar abstr cncs = grammar2canonical opts absname gr,
cncmod<-cncs,
let ModId name = concName cncmod
filename = showRawIdent name ++ ".hs" :: FilePath
]
-- | Generate Haskell code for the given concrete module.
-- The only options that make a difference are
-- @-haskell=noprefix@ and @-haskell=variants@.
concrete2haskell opts
abstr@(Abstract _ _ cats funs)
modinfo@(Concrete cnc absname _ ps lcs lns) =
haskPreamble absname cnc $$
vcat (
nl:Comment "--- Parameter types ---":
map paramDef ps ++
nl:Comment "--- Type signatures for linearization functions ---":
map signature cats ++
nl:Comment "--- Linearization functions for empty categories ---":
emptydefs ++
nl:Comment "--- Linearization types ---":
map lincatDef lcs ++
nl:Comment "--- Linearization functions ---":
lindefs ++
nl:Comment "--- Type classes for projection functions ---":
map labelClass (S.toList labels) ++
nl:Comment "--- Record types ---":
concatMap recordType recs)
where
nl = Comment ""
recs = S.toList (S.difference (records (lcs,lns)) common_records)
labels = S.difference (S.unions (map S.fromList recs)) common_labels
common_records = S.fromList [[label_s]]
common_labels = S.fromList [label_s]
label_s = LabelId (rawIdentS "s")
signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
where
abs = tcon0 (prefixIdent "A." (gId c))
lin = tcon0 lc
lf = linfunName c
lc = lincatName c
emptydefs = map emptydef (S.toList emptyCats)
emptydef c = Eqn (linfunName c,[WildP]) (Const "undefined")
emptyCats = allcats `S.difference` linfuncats
where
--funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
allcats = S.fromList [c | CatDef c _<-cats]
gId :: ToIdent i => i -> Ident
gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
. toIdent
va = haskellOption opts HaskellVariants
pure = if va then ListT else id
haskPreamble :: ModId -> ModId -> Doc
haskPreamble absname cncname =
"{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
"module" <+> cncname <+> "where" $$
"import Prelude hiding (Ordering(..))" $$
"import Control.Applicative((<$>),(<*>))" $$
"import PGF.Haskell" $$
"import qualified" <+> absname <+> "as A" $$
"" $$
"--- Standard definitions ---" $$
"linString (A.GString s) ="<+>pure "R_s [TK s]" $$
"linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
"linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
"" $$
"----------------------------------------------------" $$
"-- Automatic translation from GF to Haskell follows" $$
"----------------------------------------------------"
where
pure = if va then brackets else pp
paramDef pd =
case pd of
ParamAliasDef p t -> H.Type (conap0 (gId p)) (convLinType t)
ParamDef p pvs -> Data (conap0 (gId p)) (map paramCon pvs) derive
where
paramCon (Param c cs) = ConAp (gId c) (map (tcon0.gId) cs)
derive = ["Eq","Ord","Show"]
convLinType = ppT
where
ppT t =
case t of
FloatType -> tcon0 (identS "Float")
IntType -> tcon0 (identS "Int")
ParamType (ParamTypeId p) -> tcon0 (gId p)
RecordType rs -> tcon (rcon' ls) (map ppT ts)
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
StrType -> tcon0 (identS "Str")
TableType pt lt -> Fun (ppT pt) (ppT lt)
-- TupleType lts ->
lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
linfuncats = S.fromList linfuncatl
(linfuncatl,lindefs) = unzip (linDefs lns)
linDefs = map eqn . sortOn fst . map linDef
where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
linDef (LinDef f xs rhs0) =
(cat,(linfunName cat,(lhs,rhs)))
where
lhs = [ConP (aId f) (map VarP abs_args)]
aId f = prefixIdent "A." (gId f)
[lincat] = [lincat | LincatDef c lincat<-lcs,c==cat]
[C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
abs_args = map abs_arg args
abs_arg = prefixIdent "abs_"
args = map (prefixIdent "g" . toIdent) xs
rhs = lets (zipWith letlin args absctx)
(convert vs (coerce env lincat rhs0))
where
vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
env= [(VarValueId (Unqual x),lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
(a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
arglincat (TypeBinding _ (C.Type _ (TypeApp acat _))) = lincat
where
[lincat] = [lincat | LincatDef c lincat<-lcs,c==acat]
convert = convert' va
convert' va vs = ppT
where
ppT0 = convert' False vs
ppTv vs' = convert' va vs'
pure = if va then single else id
ppT t =
case t of
TableValue ty cs -> pure (table cs)
Selection t p -> select (ppT t) (ppT p)
ConcatValue t1 t2 -> concat (ppT t1) (ppT t2)
RecordValue r -> aps (rcon ls) (map ppT ts)
where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-r]
PredefValue p -> single (Var (toIdent p)) -- hmm
Projection t l -> ap (proj l) (ppT t)
VariantValue [] -> empty
VariantValue ts@(_:_) -> variants ts
VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
PreValue vs t' -> pure (alts t' vs)
ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs)
ErrorValue s -> ap (Const "error") (Const (show s)) -- !!
LiteralValue l -> ppL l
_ -> error ("convert "++show t)
ppL l =
case l of
FloatConstant x -> pure (lit x)
IntConstant n -> pure (lit n)
StrConstant s -> pure (token s)
pId p@(ParamId s) =
if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
table cs =
if all (null.patVars) ps
then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
else LambdaCase (map ppCase cs)
where
(ds,ts') = dedup ts
(ps,ts) = unzip [(p,t)|TableRow p t<-cs]
ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) 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 p =
case p of
ParamPattern (Param c ps) -> ConP (gId c) (map ppP ps)
RecordPattern r -> ConP (rcon' ls) (map ppP ps)
where (ls,ps) = unzip $ sortOn fst [(l,p)|RecordRow l p<-r]
WildPattern -> WildP
token s = single (c "TK" `Ap` lit s)
alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
where
alt (s,t) = Pair (List (pre s)) (ppT0 t)
pre s = map lit s
c = Const
lit s = c (show s) -- hmm
concat = if va then concat' else plusplus
where
concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
concat' t1 t2 = Op t1 "+++" t2
pure' = single -- forcing the list monad
select = if va then select' else Ap
select' (List [t]) (List [p]) = Op t "!" p
select' (List [t]) p = Op t "!$" p
select' t p = Op t "!*" p
ap = if va then ap' else Ap
where
ap' (List [f]) x = fmap f x
ap' f x = Op f "<*>" x
fmap f (List [x]) = pure' (Ap f x)
fmap f x = Op f "<$>" x
-- join = if va then join' else id
join' (List [x]) = x
join' x = c "concat" `Ap` x
empty = if va then List [] else c "error" `Ap` c (show "empty variant")
variants = if va then \ ts -> join' (List (map ppT ts))
else \ (t:_) -> ppT t
aps f [] = f
aps f (a:as) = aps (ap f a) as
dedup ts =
if M.null dups
then ([],map ppT ts)
else ([(ev i,ppT t)|(i,t)<-defs],zipWith entry ts is)
where
entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
ev i = identS ("e'"++show i)
defs = [(i1,t)|(t,i1:_:_)<-ms]
dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
ms = M.toList m
m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
is = [0..]::[Int]
--con = Cn . identS
class Records t where
records :: t -> S.Set [LabelId]
instance Records t => Records [t] where
records = S.unions . map records
instance (Records t1,Records t2) => Records (t1,t2) where
records (t1,t2) = S.union (records t1) (records t2)
instance Records LincatDef where
records (LincatDef _ lt) = records lt
instance Records LinDef where
records (LinDef _ _ lv) = records lv
instance Records LinType where
records t =
case t of
RecordType r -> rowRecords r
TableType pt lt -> records (pt,lt)
TupleType ts -> records ts
_ -> S.empty
rowRecords r = S.insert (sort ls) (records ts)
where (ls,ts) = unzip [(l,t)|RecordRow l t<-r]
instance Records LinValue where
records v =
case v of
ConcatValue v1 v2 -> records (v1,v2)
ParamConstant (Param c vs) -> records vs
RecordValue r -> rowRecords r
TableValue t r -> records (t,r)
TupleValue vs -> records vs
VariantValue vs -> records vs
PreValue alts d -> records (map snd alts,d)
Projection v l -> records v
Selection v1 v2 -> records (v1,v2)
_ -> S.empty
instance Records rhs => Records (TableRow rhs) where
records (TableRow _ v) = records v
-- | Record subtyping is converted into explicit coercions in Haskell
coerce env ty t =
case (ty,t) of
(_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
(TableType ti tv,TableValue _ cs) ->
TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
(RecordType rt,RecordValue r) ->
RecordValue [RecordRow l (coerce env ft f) |
RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]]
(RecordType rt,VarValue x)->
case lookup x env of
Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
--trace ("coerce "++render ty'++" to "++render ty) $
app (to_rcon rt) [t]
| otherwise -> t -- types match, no coercion needed
_ -> trace (render ("missing type to coerce"<+>x<+>"to"<+>render ty
$$ "in" <+> map fst env))
t
_ -> t
where
app f ts = ParamConstant (Param f ts) -- !! a hack
to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
patVars p = []
labels r = [l | RecordRow l _ <- r]
proj = Var . identS . proj'
proj' (LabelId l) = "proj_" ++ showRawIdent l
rcon = Var . rcon'
rcon' = identS . rcon_name
rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
to_rcon' = ("to_"++) . rcon_name
recordType ls =
Data lhs [app] ["Eq","Ord","Show"]:
enumAllInstance:
zipWith projection vs ls ++
[Eqn (identS (to_rcon' ls),[VarP r])
(foldl Ap (Var cn) [Var (identS (proj' l)) `Ap` Var r|l<-ls])]
where
r = identS "r"
cn = rcon' ls
-- Not all record labels are syntactically correct as type variables in Haskell
-- app = cn<+>ls
lhs = ConAp cn vs -- don't reuse record labels
app = fmap TId lhs
tapp = foldl TAp (TId cn) (map TId vs)
vs = [identS ('t':show i)|i<-[1..n]]
n = length ls
projection v l = Instance [] (TId name `TAp` tapp `TAp` TId v)
[((prj,[papp]),Var v)]
where
name = identS ("Has_"++render l)
prj = identS (proj' l)
papp = ConP cn (map VarP vs)
enumAllInstance =
Instance ctx (tEnumAll `TAp` tapp)[(lhs0 "enumAll",enumCon cn n)]
where
ctx = [tEnumAll `TAp` TId v|v<-vs]
tEnumAll = TId (identS "EnumAll")
labelClass l =
Class [] (ConAp name [r,a]) [([r],[a])]
[(identS (proj' l),TId r `Fun` TId a)]
where
name = identS ("Has_"++render l)
r = identS "r"
a = identS "a"
enumCon name arity =
if arity==0
then single (Var name)
else foldl ap (single (Var name)) (replicate arity (Const "enumAll"))
where
ap (List [f]) a = Op f "<$>" a
ap f a = Op f "<*>" a
lincatName,linfunName :: CatId -> Ident
lincatName c = prefixIdent "Lin" (toIdent c)
linfunName c = prefixIdent "lin" (toIdent c)
class ToIdent i where toIdent :: i -> Ident
instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
instance ToIdent PredefId where toIdent (PredefId s) = identC s
instance ToIdent CatId where toIdent (CatId s) = identC s
instance ToIdent C.FunId where toIdent (FunId s) = identC s
instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
qIdentC = identS . unqual
unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
unqual (Unqual n) = showRawIdent n
instance ToIdent VarId where
toIdent Anonymous = identW
toIdent (VarId s) = identC s