1 files changed, 291 insertions, 0 deletions
diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs
new file mode 100644
index 000000000..a52d00e14
--- /dev/null
+++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs
@@ -0,0 +1,291 @@
+module GF.Compile.ConcreteToHaskell where
+import Data.List(sort,sortBy,(\\))
+import Data.Function(on)
+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,allParamValues,lookupOrigInfo,allOrigInfos)
+import GF.Grammar.Macros(typeForm,collectOp)
+import GF.Grammar.Lockfield(isLockLabel)
+import GF.Grammar.Predef(cPredef)
+import GF.Compile.Compute.Predef(predef)
+import GF.Compile.Compute.Value(Predefined(..))
+import GF.Infra.Ident(Ident,identS) --,moduleNameS
+import GF.Infra.Option
+import GF.Grammar.Printer(getAbs)
+import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
+import Debug.Trace
+
+concretes2haskell opts absname gr =
+  [(cncname,concrete2haskell opts gr cenv absname cnc cncmod)
+     | let cenv = resourceValues gr,
+       cnc<-allConcretes gr absname,
+       let cncname = render cnc ++ ".hs"
+           Ok cncmod = lookupModule gr cnc
+  ]
+
+concrete2haskell opts gr cenv absname cnc modinfo =
+    render $
+      haskPreamble absname cnc $+$ "" $+$
+      vcat (neededParamTypes S.empty (params defs)) $+$ "" $+$
+      vcat (map signature (S.toList allcats)) $+$ "" $+$
+      vcat emptydefs $+$
+      vcat (map ppDef defs) $+$ "" $+$
+      vcat (map labelClass (S.toList (S.unions (map S.fromList rs)))) $+$ "" $+$
+      vcat (map recordType rs)
+  where
+    rs = S.toList (S.insert [ident2label (identS "s")] (records rhss))
+    rhss = map (snd.snd) defs
+    defs = sortBy (compare `on` fst) .
+           concatMap (toHaskell gId gr absname cenv) . 
+           M.toList $
+           jments modinfo
+
+    signature c = "lin"<>c<+>"::"<+>"A."<>gId c<+>"->"<+>"Lin"<>c
+
+    emptydefs = map emptydef (S.toList emptyCats)
+    emptydef c = "lin"<>c<+>"_"<+>"="<+>"undefined"
+
+    emptyCats = allcats `S.difference` cats
+    cats = S.fromList [c|(Just c,_)<-defs]
+    allcats = S.fromList [c|((_,c),AbsCat (Just _))<-allOrigInfos gr absname]
+            
+    params = S.toList . S.unions . map params1
+    params1 (Nothing,(_,rhs)) = paramTypes gr rhs
+    params1 (_,(_,rhs)) = tableTypes gr [rhs]
+
+    ppDef (Nothing,(lhs,rhs)) = hang (lhs<+>"=") 4 (convType gId rhs)
+    ppDef (_,(lhs,rhs)) = hang (lhs<+>"=") 4 (convert gId gr rhs)
+
+    gId :: Ident -> Doc
+    gId = if haskellOption opts HaskellNoPrefix then pp else  ("G"<>).pp
+
+    neededParamTypes have [] = []
+    neededParamTypes have (q:qs) =
+        if q `S.member` have
+        then neededParamTypes have qs
+        else let ((got,need),def) = paramType gId gr q
+             in def:neededParamTypes (S.union got have) (S.toList need++qs)
+
+haskPreamble :: ModuleName -> ModuleName -> Doc
+haskPreamble absname cncname =
+  "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $+$
+  "module" <+> cncname <+> "where" $+$
+  "import Prelude hiding (Ordering(..))" $$
+  "import qualified Data.Map as M" $+$
+  "import Data.Map((!))" $+$
+  "import qualified" <+> absname <+> "as A" $+$
+  "----------------------------------------------------" $$
+  "-- automatic translation from GF to Haskell" $$
+  "----------------------------------------------------" $$
+  "type Str = [String]" $$
+  "linString (A.GString s) = R_s [s]" $$
+  "linInt (A.GInt i) = R_s [show i]" $$
+  "linFloat (A.GFloat x) = R_s [show x]" $$
+  "" $$
+  "table is vs = let m = M.fromList (zip is vs) in (m!)"
+
+toHaskell gId gr absname cenv (name,jment) =
+  case jment of
+    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))]
+      where
+        Ok abstype = lookupFunType gr absname name
+        (absctx,abscat,absargs) = typeForm abstype
+
+        (xs,e') = getAbs (nf loc def)
+        args = map snd xs
+        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)))))
+    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 = "A."<>gId n
+
+con = Cn . identS
+
+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)
+    Sort _ -> S.empty
+    Q q -> lookup q
+    QC q -> lookup q
+    _ -> ignore
+  where
+    lookup q = case lookupOrigInfo gr q of
+                 Ok (_,ResOper  _ (Just (L _ t))) -> paramTypes gr t
+                 Ok (_,ResParam {}) -> S.singleton q
+                 _ -> ignore
+
+    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 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)
+    (RecType rt,R r) ->
+      R [(l,(Just ft,coerce ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]]
+    _ -> t
+
+
+convert gId = convert' False gId
+convertA gId = convert' True gId
+
+convert' atomic gId gr = if atomic then ppA else ppT
+  where
+    ppT t =
+      case t of
+        Let (x,(_,xt)) t -> sep ["let"<+>x<+>"="<+>ppT xt,"in"<+>ppT t]
+        Abs b x t -> "\\"<+>x<+>"->"<+>ppT t
+        V ty ts -> hang "table" 4 (sep [list (enumAll ty),list ts])
+        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
+
+    ppCase (p,t) = hang (ppP p <+> "->") 4 (ppT t)
+
+    ppB 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 t =
+      case t of
+        Vr x -> pp x
+        Cn x -> pp x
+        Con c -> gId c
+        Sort k -> pp k
+        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)
+
+    ppPredef n =
+      case predef n of
+        Ok BIND -> token "&+"
+        Ok SOFT_BIND -> token "SOFT_BIND" -- hmm
+        Ok CAPIT -> token "CAPIT" -- hmm
+        _ -> pp n
+
+    ppP p =
+      case p of
+        PC c ps -> gId c<+>fsep (map ppAP ps)
+        PP (_,c) ps -> gId c<+>fsep (map ppAP ps)
+        PR r -> rcon (map fst r)<+>fsep (map (ppAP.snd) (filter (not.isLockLabel.fst) r))
+        _ -> ppAP p
+
+    ppAP p =
+      case p of
+        PW -> pp "_"
+        PV x -> pp x
+        PString s -> doubleQuotes s
+        PInt i -> pp i
+        PFloat x -> pp x
+        PT _ p -> ppAP p
+        PAs x p -> x<>"@"<>ppAP p
+        _ -> parens (ppAP p)
+        
+    token = brackets . doubleQuotes
+
+    list = brackets . fsep . punctuate "," . map ppT
+
+    fields = map (ppA.snd.snd) . sort . filter (not.isLockLabel.fst)
+
+    enumAll ty = case allParamValues gr ty of
+                   Ok ts -> ts
+
+convType gId = ppT
+  where
+    ppT t =
+      case t of
+        Table ti tv -> ppB ti <+> "->" <+> ppT tv
+        _ -> ppB t
+
+    ppB t =
+      case t of
+        RecType rt -> rcon (map fst rt)<+>fsep (fields rt)
+        _ -> ppA t
+
+    ppA t =
+      case t of
+        Sort k -> pp k
+        QC (m,n) -> gId n
+        _ -> {-trace (show t) $-} parens (ppT 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)]))
+
+recordType ls =
+    "data"<+>app<+>"="<+>app <+> "deriving (Eq,Ord,Show)" $+$
+    vcat (map projection ls) $+$ ""
+  where
+    n = rcon ls
+    app = n<+>ls
+
+    projection l = 
+       hang ("instance"<+>"Has_"<>l<+>parens app<+>l<+>"where") 4
+            (proj l<+>parens app<+>"="<+>l)
+
+labelClass l =
+    hang ("class"<+>"Has_"<>l<+>"r"<+>"a"<+>"| r -> a"<+>"where") 4
+         (proj l<+>"::"<+>"r -> a")
+
+paramType gId gr q@(_,n) =
+    case lookupOrigInfo gr q of
+      Ok (m,ResParam (Just (L _ ps)) _)
+       | True {-m/=cPredef && m/=moduleNameS "Prelude"-} ->
+         ((S.singleton (m,n),argTypes ps),
+          "data"<+>gId (snd q)<+>"="<+>
+               sep [fsep (punctuate " |" (map param ps)),
+                    pp "deriving (Eq,Ord,Show)"])
+      _ -> ((S.empty,S.empty),empty)
+  where
+    param (n,ctx) = gId n<+>[convertA gId gr t|(_,_,t)<-ctx]
+    argTypes = S.unions . map argTypes1
+    argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]