diff options
| -rw-r--r-- | src/compiler/GF/Compile/ConcreteToCanonical.hs | 100 | ||||
| -rw-r--r-- | src/compiler/GF/Compile/ConcreteToHaskell.hs | 652 | ||||
| -rw-r--r-- | src/compiler/GF/Grammar/Canonical.hs | 20 | ||||
| -rw-r--r-- | src/compiler/GF/Haskell.hs | 6 |
4 files changed, 338 insertions, 440 deletions
diff --git a/src/compiler/GF/Compile/ConcreteToCanonical.hs b/src/compiler/GF/Compile/ConcreteToCanonical.hs index 7422b6205..34c7bee73 100644 --- a/src/compiler/GF/Compile/ConcreteToCanonical.hs +++ b/src/compiler/GF/Compile/ConcreteToCanonical.hs @@ -13,7 +13,7 @@ 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,identS,prefixIdent,showIdent,isWildIdent) +import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent) import GF.Infra.Option(optionsPGF) import PGF.Internal(Literal(..)) import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) @@ -95,15 +95,11 @@ toCanonical gr absname cenv (name,jment) = [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))] where tts = tableTypes gr [e'] --- Ok abstype = lookupFunType gr absname name --- (absctx,_abscat,_absargs) = typeForm abstype + e' = unAbs (length params) $ nf loc (mkAbs params (mkApp def (map Vr args))) params = [(b,x)|(b,x,_)<-ctx] args = map snd params --- abs_args = map (prefixIdent "abs_") args --- lhs = [ConP (aId name) (map VarP abs_args)] --- rhs = foldr letlin e' (zip args absctx) AnyInd _ m -> case lookupOrigInfo gr (m,name) of Ok (m,jment) -> toCanonical gr absname cenv (name,jment) @@ -117,23 +113,6 @@ toCanonical gr absname cenv (name,jment) = unAbs n (Abs _ _ t) = unAbs (n-1) t unAbs _ t = t - -con = Cn . identS -{- -tableTypes gr ts = S.unions (map tabtys ts) - where - tabtys t = - case t of - ConcatValue v1 v2 -> S.union (tabtys v1) (tabtys v2) - TableValue t tvs -> S.unions (paramTypes gr t:[tabtys t|TableRowValue _ t<-tvs]) - VTableValue t ts -> (S.unions (paramTypes gr t:map tabtys ts)) - Projection lv l -> tabtys lv - Selection tv pv -> S.union (tabtys tv) (tabtys pv) - VariantValue vs -> S.unions (map tabtys vs) - RecordValue rvs -> S.unions [tabtys t|RecordRowValue _ t<-rvs] - TupleValue lvs -> S.unions (map tabtys lvs) - _ -> S.empty --} tableTypes gr ts = S.unions (map tabtys ts) where tabtys t = @@ -163,37 +142,6 @@ paramTypes gr t = ignore = trace ("Ignore: "++show t) S.empty -{- -records ts = S.unions (map recs ts) - where - recs t = - case t of - R r -> S.insert (labels r) (records (map (snd.snd) r)) - RecType r -> S.insert (labels r) (records (map snd r)) - _ -> collectOp recs t - - labels = sort . filter (not . isLockLabel) . map fst - - -coerce env ty t = - case (ty,t) of - (_,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 env ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]] - (RecType rt,Vr 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 (map fst rt)) t - _ -> trace ("no coerce to "++render ty) t - _ -> t - where - extend env (x,(Just ty,rhs)) = (x,ty):env - extend env _ = env --} convert gr = convert' gr [] convert' gr vs = ppT @@ -203,8 +151,6 @@ convert' gr vs = ppT ppT t = case t of - -- Only for 'let' inserted on the top-level by this converter: --- Let (x,(_,xt)) t -> let1 x (ppT0 xt) (ppT t) -- Abs b x t -> ... -- V ty ts -> VTableValue (convType ty) (map ppT ts) V ty ts -> TableValue (convType ty) [TableRowValue (ppP p) (ppT t)|(p,t)<-zip ps ts] @@ -234,13 +180,15 @@ convert' gr vs = ppT ppPredef n = case predef n of - Ok BIND -> c "Predef.BIND" - Ok SOFT_BIND -> c "Predef.SOFT_BIND" - Ok SOFT_SPACE -> c "Predef.SOFT_SPACE" - Ok CAPIT -> c "Predef.CAPIT" - Ok ALL_CAPIT -> c "Predef.ALL_CAPIT" + Ok BIND -> p "BIND" + Ok SOFT_BIND -> p "SOFT_BIND" + Ok SOFT_SPACE -> p "SOFT_SPACE" + Ok CAPIT -> p "CAPIT" + Ok ALL_CAPIT -> p "ALL_CAPIT" _ -> VarValue (gId n) - + where + p = PredefValue . PredefId + ppP p = case p of PC c ps -> ParamPattern (Param (gId c) (map ppP ps)) @@ -277,38 +225,14 @@ convert' gr vs = ppT fields = map field . filter (not.isLockLabel.fst) field (l,(_,t)) = RecordRow (lblId l) (ppT t) --c = Const - c = VarValue . VarValueId - lit s = c (show s) -- hmm + --c = VarValue . VarValueId + --lit s = c (show s) -- hmm ap f a = case f of ParamConstant (Param p ps) -> ParamConstant (Param p (ps++[a])) _ -> error $ "convert' ap: "++render (ppA f <+> ppA a) - join = id - --- 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 List (map ppT ts) - else Lets [(ev i,ppT t)|(i,t)<-defs] (List (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] --} - concatValue v1 v2 = case (v1,v2) of (StrConstant "",_) -> v2 diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index fc5c689fc..51ed5242e 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -1,370 +1,346 @@ -- | Translate concrete syntax to Haskell module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where -import Data.List(sort,sortBy) -import Data.Function(on) +import Data.List(isPrefixOf,sort,sortOn) import qualified Data.Map as M import qualified Data.Set as S -import GF.Data.ErrM -import GF.Data.Utilities(mapSnd) import GF.Text.Pretty -import GF.Grammar.Grammar -import GF.Grammar.Lookup(lookupFunType,lookupOrigInfo,allOrigInfos)--,allParamValues -import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp) -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(Ident,identS,prefixIdent) --,moduleNameS +--import GF.Grammar.Predef(cPredef,cInts) +--import GF.Compile.Compute.Predef(predef) +--import GF.Compile.Compute.Value(Predefined(..)) +import GF.Infra.Ident(Ident,identS,identW,prefixIdent) import GF.Infra.Option -import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) -import GF.Haskell ---import GF.Grammar.Canonical ---import GF.Compile.ConcreteToCanonical -import Debug.Trace +import GF.Haskell as H +import GF.Grammar.Canonical as C +import GF.Compile.ConcreteToCanonical +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 = - [(cncname,concrete2haskell opts gr cenv absname cnc cncmod) - | let cenv = resourceValues opts gr, - cnc<-allConcretes gr absname, - let cncname = render cnc ++ ".hs" :: FilePath - Ok cncmod = lookupModule gr cnc -{- (_,cnc)<-concretes2canonical opt absname gr, - let ModId name = concName cnc - cncname = name ++ ".hs" :: FilePath--} + [(filename,render80 $ concrete2haskell opts abstr cncmod) + | let Grammar abstr cncs = grammar2canonical opts absname gr, + cncmod<-cncs, + let ModId name = concName cncmod + filename = 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 gr cenv absname cnc modinfo = - renderStyle style{lineLength=80,ribbonsPerLine=1} $ - haskPreamble va absname cnc $$ vcat ( - nl:Comment "--- Parameter types ---": - neededParamTypes S.empty (params defs) ++ - nl:Comment "--- Type signatures for linearization functions ---": - map signature (S.toList allcats)++ - nl:Comment "--- Linearization functions for empty categories ---": - emptydefs ++ - nl:Comment "--- Linearization types and linearization functions ---": - map ppDef defs ++ - nl:Comment "--- Type classes for projection functions ---": - map labelClass (S.toList labels) ++ - nl:Comment "--- Record types ---": - concatMap recordType recs) +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 - recs = S.toList (S.difference (records rhss) common_records) common_records = S.fromList [[label_s]] common_labels = S.fromList [label_s] - label_s = ident2label (identS "s") - - rhss = map (either snd (snd.snd)) defs - defs = sortBy (compare `on` either (const Nothing) (Just . fst)) . - concatMap (toHaskell gId gr absname cenv) . - M.toList $ - jments modinfo + label_s = LabelId "s" --- signature c = "lin"<>c<+>"::"<+>"A."<>gId c<+>"->"<+>"Lin"<>c --- signature c = "--lin"<>c<+>":: (Applicative f,Monad f) =>"<+>"A."<>gId c<+>"->"<+>"f Lin"<>c - signature c = TypeSig lf (Fun abs (pure lin)) + signature (CatDef c _) = TypeSig lf (Fun abs (pure lin)) where abs = tcon0 (prefixIdent "A." (gId c)) lin = tcon0 lc - lf = prefixIdent "lin" c - lc = prefixIdent "Lin" c + lf = linfunName c + lc = lincatName c emptydefs = map emptydef (S.toList emptyCats) - emptydef c = Eqn (prefixIdent "lin" c,[WildP]) (Const "undefined") - - emptyCats = allcats `S.difference` cats - cats = S.fromList [c|Right (c,_)<-defs] - allcats = S.fromList [c|((_,c),AbsCat (Just _))<-allOrigInfos gr absname] + emptydef c = Eqn (linfunName c,[WildP]) (Const "undefined") - params = S.toList . S.unions . map params1 - params1 (Left (_,rhs)) = paramTypes gr rhs - params1 (Right (_,(_,rhs))) = tableTypes gr [rhs] - - ppDef (Left (lhs,rhs)) = lhs (convType va gId rhs) - ppDef (Right (_,(lhs,rhs))) = lhs (convert va gId gr rhs) + 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 - gId :: Ident -> Ident - gId = if haskellOption opts HaskellNoPrefix then id else prefixIdent "G" va = haskellOption opts HaskellVariants pure = if va then ListT else id - neededParamTypes have [] = [] - neededParamTypes have (q:qs) = - if q `S.member` have - then neededParamTypes have qs - else let ((got,need),def) = paramType va gId gr q - in def++neededParamTypes (S.union got have) (S.toList need++qs) - -haskPreamble :: Bool -> ModuleName -> ModuleName -> Doc -haskPreamble va 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 - -toHaskell gId gr absname cenv (name,jment) = - case jment of - CncCat (Just (L loc typ)) _ _ pprn _ -> - [Left (tsyn0 (prefixIdent "Lin" name),nf loc typ)] - CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ -> --- trace (render (name<+>hcat[parens (x<>"::"<>t)|(_,x,t)<-ctx]<+>"::"<+>cat)) $ - [Right (cat,(Eqn (prefixIdent "lin" cat,lhs),coerce [] lincat rhs))] + 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 - Ok abstype = lookupFunType gr absname name - (absctx,_abscat,_absargs) = typeForm abstype - - 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 (prefixIdent "abs_") args - lhs = [ConP (aId name) (map VarP abs_args)] - rhs = foldr letlin e' (zip args absctx) - letlin (a,(_,_,at)) = - 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) - _ -> [] - _ -> [] - where - nf loc = normalForm cenv (L loc name) - aId n = prefixIdent "A." (gId n) - - unAbs 0 t = t - unAbs n (Abs _ _ t) = unAbs (n-1) t - unAbs _ t = t - + pure = if va then brackets else pp -con = Cn . identS + 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"] -tableTypes gr ts = S.unions (map tabtys ts) - where - tabtys t = - case t of - V t cc -> S.union (paramTypes gr t) (tableTypes gr cc) - T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs)) - _ -> collectOp tabtys t - -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))) -> - S.insert q (paramTypes gr t) - Ok (_,ResParam {}) -> S.singleton q - _ -> ignore - - ignore = trace ("Ignore: "++show t) S.empty + 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 -records ts = S.unions (map recs ts) - where - recs t = - case t of - R r -> S.insert (labels r) (records (map (snd.snd) r)) - RecType r -> S.insert (labels r) (records (map snd r)) - _ -> collectOp recs t + rhs = lets (zipWith letlin args absctx) + (convert vs (coerce env lincat rhs0)) + where + vs = [(VarValueId x,a)|(VarId x,a)<-zip xs args] + env= [(VarValueId 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))) - labels = sort . filter (not . isLockLabel) . map fst + 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 + IntConstant n -> pure (lit n) + StrConstant s -> pure (token s) + 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)) -- !! + _ -> error ("convert "++show t) + + pId p@(ParamId s) = + if "to_R_" `isPrefixOf` 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)|TableRowValue p t<-cs] + ppCase (TableRowValue 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 TableRowValue where + records (TableRowValue _ v) = records v + + +-- | Record subtyping is converted into explicit coercions in Haskell coerce env ty t = case (ty,t) of - (_,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 env ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]] - (RecType rt,Vr x)-> + (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts) + (TableType ti tv,TableValue _ cs) -> + TableValue ti [TableRowValue p (coerce env tv t)|TableRowValue 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 (map fst rt)) t - _ -> trace ("no coerce to "++render ty) t + --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 - extend env (x,(Just ty,rhs)) = (x,ty):env - extend env _ = env - -convert va gId gr = convert' va gId [] gr - -convert' va gId vs gr = ppT - where - ppT0 = convert' False gId vs gr - ppTv vs' = convert' va gId vs' gr - - ppT t = - case t of - -- Only for 'let' inserted on the top-level by this converter: - Let (x,(_,xt)) t -> let1 x (ppT0 xt) (ppT t) --- Abs b x t -> ... - V ty ts -> pure (c "table" `Ap` dedup ts) - T (TTyped ty) cs -> pure (LambdaCase (map ppCase cs)) - S t p -> select (ppT t) (ppT p) - C t1 t2 -> concat (ppT t1) (ppT t2) - App f a -> ap (ppT f) (ppT a) - R r -> aps (ppT (rcon (map fst r))) (fields r) - P t l -> ap (ppT (proj l)) (ppT t) - FV [] -> empty - Vr x -> if x `elem` vs then pure (Var x) else Var x - Cn x -> pure (Var x) - Con c -> pure (Var (gId c)) - Sort k -> pure (Var k) - EInt n -> pure (lit n) - Q (m,n) -> if m==cPredef then pure (ppPredef n) else Var (qual m n) - QC (m,n) -> pure (Var (gId (qual m n))) - K s -> pure (token s) - Empty -> pure (List []) - FV ts@(_:_) -> variants ts - Alts t' vs -> pure (alts t' vs) - - ppCase (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 - PC c ps -> ConP (gId c) (map ppP ps) - PP (_,c) ps -> ConP (gId c) (map ppP ps) - PR r -> ConP (rcon' (map fst r)) (map (ppP.snd) (filter (not.isLockLabel.fst) r)) - PW -> WildP - 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) - - token s = single (c "TK" `Ap` lit s) - - alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t') - where - alt (t,p) = Pair (List (pre p)) (ppT0 t) + app f ts = ParamConstant (Param f ts) -- !! a hack + to_rcon = ParamId . to_rcon' . labels - pre (K s) = [lit s] - pre (Strs ts) = concatMap pre ts - pre (EPatt p) = pat p - pre t = error $ "pre "++show t +patVars p = [] - pat (PString s) = [lit s] - pat (PAlt p1 p2) = pat p1++pat p2 - pat p = error $ "pat "++show p +labels r = [l|RecordRow l _<-r] - fields = map (ppT.snd.snd) . sort . filter (not.isLockLabel.fst) - - 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 = if va then single else id - 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 List (map ppT ts) - else Lets [(ev i,ppT t)|(i,t)<-defs] (List (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] - -patVars p = - case p of - PV x -> [x] - PAs x p -> x:patVars p - _ -> collectPattOp patVars p - -convType va gId = ppT - where - ppT t = - case t of - Table ti tv -> Fun (ppT ti) (if va then ListT (ppT tv) else ppT tv) - RecType rt -> tcon (rcon' (map fst rt)) (fields rt) - App tf ta -> TAp (ppT tf) (ppT ta) - FV [] -> tcon0 (identS "({-empty variant-})") - Sort k -> tcon0 k - EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal - FV (t:ts) -> ppT t -- !! - QC (m,n) -> tcon0 (gId (qual m n)) - Q (m,n) -> tcon0 (gId (qual m n)) - _ -> error $ "Missing case in convType for: "++show t - - fields = map (ppT.snd) . sort . filter (not.isLockLabel.fst) - -proj = con . proj' -proj' l = "proj_"++render l -rcon = con . rcon_name +proj = Var . identS . proj' +proj' (LabelId l) = "proj_"++l +rcon = Var . rcon' rcon' = identS . rcon_name -rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)]) -to_rcon = con . to_rcon' +rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls]) + to_rcon' = ("to_"++) . rcon_name recordType ls = @@ -405,31 +381,6 @@ labelClass l = r = identS "r" a = identS "a" -paramType va gId gr q@(_,n) = - case lookupOrigInfo gr q of - Ok (m,ResParam (Just (L _ ps)) _) - {- - | m/=cPredef && m/=moduleNameS "Prelude"-} -> - ((S.singleton (m,n),argTypes ps), - [Data (conap0 name) (map (param m) ps)["Eq","Ord","Show"], - Instance [] (TId (identS "EnumAll") `TAp` TId name) - [(lhs0 "enumAll",foldr1 plusplus (map (enumParam m) ps))]] - ) - where name = gId (qual m n) - Ok (m,ResOper _ (Just (L _ t))) - | m==cPredef && n==cInts -> - ((S.singleton (m,n),S.empty), - [Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))]) - | otherwise -> - ((S.singleton (m,n),paramTypes gr t), - [Type (conap0 (gId (qual m n))) (convType va gId t)]) - _ -> ((S.empty,S.empty),[]) - where - param m (n,ctx) = ConAp (gId (qual m n)) [convType va gId t|(_,_,t)<-ctx] - argTypes = S.unions . map argTypes1 - argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx] - - enumParam m (n,ctx) = enumCon (gId (qual m n)) (length ctx) - enumCon name arity = if arity==0 then single (Var name) @@ -438,5 +389,18 @@ enumCon name arity = ap (List [f]) a = Op f "<$>" a ap f a = Op f "<*>" a -qual :: ModuleName -> Ident -> Ident -qual m = prefixIdent (render m++"_") +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 s) = identS s +instance ToIdent PredefId where toIdent (PredefId s) = identS s +instance ToIdent CatId where toIdent (CatId s) = identS s +instance ToIdent C.FunId where toIdent (FunId s) = identS s +instance ToIdent VarValueId where toIdent (VarValueId s) = identS s + +instance ToIdent VarId where + toIdent Anonymous = identW + toIdent (VarId s) = identS s diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs index 6d08b815f..0da72d634 100644 --- a/src/compiler/GF/Grammar/Canonical.hs +++ b/src/compiler/GF/Grammar/Canonical.hs @@ -14,6 +14,7 @@ data Grammar = Grammar Abstract [Concrete] deriving Show -- | Abstract Syntax data Abstract = Abstract ModId Flags [CatDef] [FunDef] deriving Show +abstrName (Abstract mn _ _ _) = mn data CatDef = CatDef CatId [CatId] deriving Show data FunDef = FunDef FunId Type deriving Show @@ -54,6 +55,7 @@ data LinValue = ConcatValue LinValue LinValue | FloatConstant Float | IntConstant Int | ParamConstant ParamValue + | PredefValue PredefId | RecordValue [RecordRowValue] | StrConstant String | TableValue LinType [TableRowValue] @@ -64,29 +66,30 @@ data LinValue = ConcatValue LinValue LinValue | PreValue [([String], LinValue)] LinValue | Projection LinValue LabelId | Selection LinValue LinValue - deriving (Eq,Show) + deriving (Eq,Ord,Show) data LinPattern = ParamPattern ParamPattern | RecordPattern [RecordRow LinPattern] | WildPattern - deriving (Eq,Show) + deriving (Eq,Ord,Show) type ParamValue = Param LinValue type ParamPattern = Param LinPattern type ParamValueDef = Param ParamId -data Param arg = Param ParamId [arg] deriving (Eq,Show) +data Param arg = Param ParamId [arg] deriving (Eq,Ord,Show) type RecordRowType = RecordRow LinType type RecordRowValue = RecordRow LinValue data RecordRow rhs = RecordRow LabelId rhs deriving (Eq,Ord,Show) -data TableRowValue = TableRowValue LinPattern LinValue deriving (Eq,Show) +data TableRowValue = TableRowValue LinPattern LinValue deriving (Eq,Ord,Show) -- *** Identifiers in Concrete Syntax -newtype LabelId = LabelId String deriving (Eq,Ord,Show) -data VarValueId = VarValueId String deriving (Eq,Show) +newtype PredefId = PredefId String deriving (Eq,Ord,Show) +newtype LabelId = LabelId String deriving (Eq,Ord,Show) +data VarValueId = VarValueId String deriving (Eq,Ord,Show) -- | Name of param type or param value newtype ParamId = ParamId String deriving (Eq,Ord,Show) @@ -96,7 +99,7 @@ newtype ParamId = ParamId String deriving (Eq,Ord,Show) newtype ModId = ModId String deriving (Eq,Show) -newtype CatId = CatId String deriving (Eq,Show) +newtype CatId = CatId String deriving (Eq,Ord,Show) newtype FunId = FunId String deriving (Eq,Show) data VarId = Anonymous | VarId String deriving Show @@ -203,6 +206,7 @@ instance PPA LinValue where FloatConstant f -> pp f IntConstant n -> pp n ParamConstant pv -> ppA pv + PredefValue p -> ppA p RecordValue [] -> pp "<>" RecordValue rvs -> block rvs PreValue alts def -> @@ -245,6 +249,8 @@ instance Pretty ModId where pp (ModId s) = pp s instance Pretty CatId where pp (CatId s) = pp s instance Pretty FunId where pp (FunId s) = pp s instance Pretty LabelId where pp (LabelId s) = pp s +instance Pretty PredefId where pp = ppA +instance PPA PredefId where ppA (PredefId s) = pp s instance Pretty ParamId where pp = ppA instance PPA ParamId where ppA (ParamId s) = pp s instance Pretty VarValueId where pp (VarValueId s) = pp s diff --git a/src/compiler/GF/Haskell.hs b/src/compiler/GF/Haskell.hs index 57601c1d5..8cb8a9177 100644 --- a/src/compiler/GF/Haskell.hs +++ b/src/compiler/GF/Haskell.hs @@ -40,6 +40,9 @@ tvar = TId tcon0 = TId tcon c = foldl TAp (TId c) +lets [] e = e +lets ds e = Lets ds e + let1 x xe e = Lets [(x,xe)] e single x = List [x] @@ -113,7 +116,8 @@ instance Pretty Exp where Op e1 op e2 -> hang (ppB e1<+>op) 2 (ppB e2) Lets bs e -> sep ["let"<+>vcat [hang (x<+>"=") 2 xe|(x,xe)<-bs], "in" <+>e] - LambdaCase alts -> hang "\\case" 4 (vcat [p<+>"->"<+>e|(p,e)<-alts]) + LambdaCase alts -> + hang "\\case" 2 (vcat [hang (p<+>"->") 2 e|(p,e)<-alts]) _ -> ppB e ppB e = case flatAp e of f:as -> hang (ppA f) 2 (sep (map ppA as)) |