summaryrefslogtreecommitdiff
path: root/src/compiler/GF/Compile
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF/Compile')
-rw-r--r--src/compiler/GF/Compile/ConcreteToHaskell.hs135
1 files changed, 93 insertions, 42 deletions
diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs
index a52d00e14..783cce9b8 100644
--- a/src/compiler/GF/Compile/ConcreteToHaskell.hs
+++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs
@@ -1,5 +1,5 @@
module GF.Compile.ConcreteToHaskell where
-import Data.List(sort,sortBy,(\\))
+import Data.List(sort,sortBy)
import Data.Function(on)
import qualified Data.Map as M
import qualified Data.Set as S
@@ -8,14 +8,13 @@ import GF.Data.Utilities(mapSnd)
import GF.Text.Pretty
import GF.Grammar.Grammar
import GF.Grammar.Lookup(lookupFunType,allParamValues,lookupOrigInfo,allOrigInfos)
-import GF.Grammar.Macros(typeForm,collectOp)
+import GF.Grammar.Macros(typeForm,collectOp,mkAbs,mkApp)
import GF.Grammar.Lockfield(isLockLabel)
-import GF.Grammar.Predef(cPredef)
+import GF.Grammar.Predef(cPredef,cInts)
import GF.Compile.Compute.Predef(predef)
import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(Ident,identS) --,moduleNameS
+import GF.Infra.Ident(Ident,identS,prefixIdent) --,moduleNameS
import GF.Infra.Option
-import GF.Grammar.Printer(getAbs)
import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
import Debug.Trace
@@ -93,18 +92,21 @@ toHaskell gId gr absname cenv (name,jment) =
CncCat (Just (L loc typ)) _ _ pprn _ ->
[(Nothing,("type"<+>"Lin"<>name,nf loc typ))]
CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
- [(Just cat,("lin"<>cat<+>lhs,coerce lincat rhs))]
+-- trace (render (name<+>hcat[parens (x<>"::"<>t)|(_,x,t)<-ctx]<+>"::"<+>cat)) $
+ [(Just cat,("lin"<>cat<+>lhs,coerce [] lincat rhs))]
where
Ok abstype = lookupFunType gr absname name
(absctx,abscat,absargs) = typeForm abstype
- (xs,e') = getAbs (nf loc def)
- args = map snd xs
+ e' = unAbs (length params) $
+ nf loc (mkAbs params (mkApp def (map Vr args)))
+ params = [(b,prefixIdent "g" x)|(b,x,_)<-ctx]
+ args = map snd params
abs_args = map ("abs_"<>) args
lhs = if null args then aId name else parens (aId name<+>hsep abs_args)
rhs = foldr letlin e' (zip args absctx)
letlin (a,(_,_,at)) =
- Let (a,(Nothing,(App (con ("lin"++render at)) (con ("abs_"++render a)))))
+ Let (a,(Just (con ("Lin"++render at)),(App (con ("lin"++render at)) (con ("abs_"++render a)))))
AnyInd _ m -> case lookupOrigInfo gr (m,name) of
Ok (m,jment) -> toHaskell gId gr absname cenv (name,jment)
_ -> []
@@ -113,6 +115,11 @@ toHaskell gId gr absname cenv (name,jment) =
nf loc = normalForm cenv (L loc name)
aId n = "A."<>gId n
+ unAbs 0 t = t
+ unAbs n (Abs _ _ t) = unAbs (n-1) t
+ unAbs _ t = t
+
+
con = Cn . identS
tableTypes gr ts = S.unions (map tabtys ts)
@@ -127,13 +134,17 @@ paramTypes gr t =
case t of
RecType fs -> S.unions (map (paramTypes gr.snd) fs)
Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
+ App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
Sort _ -> S.empty
+ EInt _ -> S.empty
Q q -> lookup q
QC q -> lookup q
+ FV ts -> S.unions (map (paramTypes gr) ts)
_ -> ignore
where
lookup q = case lookupOrigInfo gr q of
- Ok (_,ResOper _ (Just (L _ t))) -> paramTypes gr t
+ Ok (_,ResOper _ (Just (L _ t))) ->
+ S.insert q (paramTypes gr t)
Ok (_,ResParam {}) -> S.singleton q
_ -> ignore
@@ -152,23 +163,33 @@ records ts = S.unions (map recs ts)
labels = sort . filter (not . isLockLabel) . map fst
-coerce ty t =
+coerce env ty t =
case (ty,t) of
- (_,Let d t) -> Let d (coerce ty t)
- (_,FV ts) -> FV (map (coerce ty) ts)
- (Table ti tv,V _ ts) -> V ti (map (coerce tv) ts)
- (Table ti tv,T (TTyped _) cs) -> T (TTyped ti) (mapSnd (coerce tv) cs)
+ (_,Let d t) -> Let d (coerce (extend env d) ty t)
+ (_,FV ts) -> FV (map (coerce env ty) ts)
+ (Table ti tv,V _ ts) -> V ti (map (coerce env tv) ts)
+ (Table ti tv,T (TTyped _) cs) -> T (TTyped ti) (mapSnd (coerce env tv) cs)
(RecType rt,R r) ->
- R [(l,(Just ft,coerce ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]]
+ R [(l,(Just ft,coerce env ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]]
+ (RecType rt,Vr x)->
+ case lookup x env of
+ Just ty' | ty'/=ty ->
+ --trace ("coerce "++render ty'++" to "++render ty) $
+ App (to_rcon (map fst rt)) t
+ _ -> trace ("no coerce to "++render ty) t
+ _ -> t
_ -> t
-
+ where
+ extend env (x,(Just ty,rhs)) = (x,ty):env
+ extend env _ = env
convert gId = convert' False gId
convertA gId = convert' True gId
convert' atomic gId gr = if atomic then ppA else ppT
where
- ppT t =
+ ppT = ppT' False
+ ppT' loop t =
case t of
Let (x,(_,xt)) t -> sep ["let"<+>x<+>"="<+>ppT xt,"in"<+>ppT t]
Abs b x t -> "\\"<+>x<+>"->"<+>ppT t
@@ -176,33 +197,38 @@ convert' atomic gId gr = if atomic then ppA else ppT
T (TTyped ty) cs -> hang "\\case" 2 (vcat (map ppCase cs))
S t p -> hang (ppB t) 4 (ppA p)
C t1 t2 -> hang (ppA t1<+>"++") 4 (ppA t2)
- _ -> ppB t
+ _ -> ppB' loop t
ppCase (p,t) = hang (ppP p <+> "->") 4 (ppT t)
- ppB t =
+ ppB = ppB' False
+ ppB' loop t =
case t of
App f a -> ppB f<+>ppA a
R r -> rcon (map fst r)<+>fsep (fields r)
P t l -> ppB (proj l)<+>ppA t
FV [] -> "error"<+>doubleQuotes "empty variant"
- _ -> ppA t
+ _ -> ppA' loop t
+
+ ppA = ppA' False
- ppA t =
+ ppA' True t = error $ "Missing case in convert': "++show t
+ ppA' loop t =
case t of
Vr x -> pp x
Cn x -> pp x
Con c -> gId c
Sort k -> pp k
+ EInt n -> pp n
Q (m,n) -> if m==cPredef
then ppPredef n
else pp n
QC (m,n) -> gId n
K s -> token s
Empty -> pp "[]"
- FV (t:ts) -> ppA t -- !!
- Alts t _ -> ppA t -- !!!
- _ -> {-trace (show t) $-} parens (ppT t)
+ FV (t:ts) -> "{-variants-}"<>ppA t -- !!
+ Alts t _ -> "{-alts-}"<>ppA t -- !!!
+ _ -> parens (ppT' True t)
ppPredef n =
case predef n of
@@ -238,39 +264,58 @@ convert' atomic gId gr = if atomic then ppA else ppT
enumAll ty = case allParamValues gr ty of
Ok ts -> ts
-convType gId = ppT
+convType = convType' False
+convTypeA = convType' True
+
+convType' atomic gId = if atomic then ppA else ppT
where
- ppT t =
+ ppT = ppT' False
+ ppT' loop t =
case t of
Table ti tv -> ppB ti <+> "->" <+> ppT tv
- _ -> ppB t
+ _ -> ppB' loop t
- ppB t =
+ ppB = ppB' False
+ ppB' loop t =
case t of
RecType rt -> rcon (map fst rt)<+>fsep (fields rt)
- _ -> ppA t
+ App tf ta -> ppB tf <+> ppA ta
+ FV [] -> pp "({-empty variant-})"
+ _ -> ppA' loop t
- ppA t =
+ ppA = ppA' False
+ ppA' True t = error $ "Missing case in convType for: "++show t
+ ppA' loop t =
case t of
Sort k -> pp k
+ EInt n -> parens ("{-"<>n<>"-}") -- type level numeric literal
+ FV (t:ts) -> "{-variants-}"<>ppA t -- !!
QC (m,n) -> gId n
- _ -> {-trace (show t) $-} parens (ppT t)
+ Q (m,n) -> gId n
+ _ -> {-trace (show t) $-} parens (ppT' True t)
fields = map (ppA.snd) . sort . filter (not.isLockLabel.fst)
proj l = con ("proj_"++render l)
-rcon ls = con ("R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)]))
+rcon = con . rcon_name
+rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)])
+to_rcon = con . ("to_"++) . rcon_name
recordType ls =
"data"<+>app<+>"="<+>app <+> "deriving (Eq,Ord,Show)" $+$
- vcat (map projection ls) $+$ ""
+ vcat (zipWith projection vs ls) $+$
+ to_rcon ls<+>"r"<+>"="<+>cn<+>fsep [parens (proj l<+>"r")|l<-ls] $+$ ""
where
- n = rcon ls
- app = n<+>ls
+ cn = rcon ls
+ -- Not all record labels are syntactically correct as type variables in Haskell
+ -- app = cn<+>ls
+ app = cn<+>hsep vs -- don't reuse record labels
+ vs = ["t"<>i|i<-[1..n]]
+ n = length ls
- projection l =
- hang ("instance"<+>"Has_"<>l<+>parens app<+>l<+>"where") 4
- (proj l<+>parens app<+>"="<+>l)
+ projection v l =
+ hang ("instance"<+>"Has_"<>l<+>parens app<+>v<+>"where") 4
+ (proj l<+>parens app<+>"="<+>v)
labelClass l =
hang ("class"<+>"Has_"<>l<+>"r"<+>"a"<+>"| r -> a"<+>"where") 4
@@ -279,13 +324,19 @@ labelClass l =
paramType gId gr q@(_,n) =
case lookupOrigInfo gr q of
Ok (m,ResParam (Just (L _ ps)) _)
- | True {-m/=cPredef && m/=moduleNameS "Prelude"-} ->
+ {- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
((S.singleton (m,n),argTypes ps),
- "data"<+>gId (snd q)<+>"="<+>
+ "data"<+>gId n<+>"="<+>
sep [fsep (punctuate " |" (map param ps)),
pp "deriving (Eq,Ord,Show)"])
+ Ok (m,ResOper _ (Just (L _ t)))
+ | m==cPredef && n==cInts ->
+ ((S.singleton (m,n),S.empty),pp "type GInts n = Int")
+ | otherwise ->
+ ((S.singleton (m,n),paramTypes gr t),
+ "type"<+>gId n<+>"="<+>convType gId t)
_ -> ((S.empty,S.empty),empty)
where
- param (n,ctx) = gId n<+>[convertA gId gr t|(_,_,t)<-ctx]
+ param (n,ctx) = gId n<+>[convTypeA gId t|(_,_,t)<-ctx]
argTypes = S.unions . map argTypes1
argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 13:05:05 +0000