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 t = + ppA = ppA' False + + 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]