path: root/src/compiler/GF/Compile/ConcreteToHaskell.hs

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]