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,lookupOrigInfo,allOrigInfos)--,allParamValues
import GF.Grammar.Macros(typeForm,collectOp,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.Infra.Option
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 $$ "" $$
      "--- Parameter types ---" $$
      vcat (neededParamTypes S.empty (params defs)) $$ "" $$
      "--- Type signatures for linearization functions ---" $$
      vcat (map signature (S.toList allcats)) $$ "" $$
      "--- Linearization functions for empty categories ---" $$
      vcat emptydefs $$ "" $$
      "--- Linearization types and linearization functions ---" $$
      vcat (map ppDef defs) $$ "" $$
      "--- Type classes for projection functions ---" $$
      vcat (map labelClass (S.toList labels)) $$ "" $$
      "--- Record types ---" $$
      vcat (map recordType recs)
  where
    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 (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 Control.Applicative((<$>),(<*>))" $$
  "import qualified Data.Map as M" $$
  "import Data.Map((!))" $$
  "import PGF.Haskell" $$
  "import qualified" <+> absname <+> "as A" $$
  "" $$
  "--- Standard definitions ---" $$
  "linString (A.GString s) = R_s [TK s]" $$
  "linInt (A.GInt i) = R_s [TK (show i)]" $$
  "linFloat (A.GFloat x) = R_s [TK (show x)]" $$
  "" $$
  "----------------------------------------------------" $$
  "-- Automatic translation from GF to Haskell follows" $$
  "----------------------------------------------------"

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 _ ->
--      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

        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,(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 = "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)
  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



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 gId = convert' False gId
convertA gId = convert' True gId

convert' atomic gId gr = if atomic then ppA else ppT
  where
    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
--      V ty ts -> hang "table" 4 (sep [list (enumAll ty),list ts])
        V ty ts -> hang "table" 4 (dedup 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' loop t

    ppCase (p,t) = hang (ppP p <+> "->") 4 (ppT 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' loop 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 (qual m n)
        QC (m,n) -> gId (qual m n)
        K s -> token s
        Empty -> pp "[]"
        FV (t:ts) -> "{-variants-}"<>ppA t -- !!
        Alts t' vs -> alts t' vs
        _ -> parens (ppT' True t)

    ppPredef n =
      case predef n of
        Ok BIND      -> brackets "BIND"
        Ok SOFT_BIND -> brackets "SOFT_BIND"
        Ok CAPIT     -> brackets "CAPIT"
        _ -> 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 s = brackets ("TK"<+>doubleQuotes s)

    alts t' vs = brackets ("TP" <+> list' (map alt vs) <+> ppT t')
      where
        alt (t,p) = parens (show (pre p)<>","<>ppT t)

        pre (K s) = [s]
        pre (Strs ts) = concatMap pre ts
        pre (EPatt p) = pat p
        pre t = error $ "pre "++show t

        pat (PString s) = [s]
        pat (PAlt p1 p2) = pat p1++pat p2
        pat p = error $ "pat "++show p

    fields = map (ppA.snd.snd) . sort . filter (not.isLockLabel.fst)

--  enumAll ty = case allParamValues gr ty of Ok ts -> ts

    list = brackets . fsep . punctuate "," . map ppT
    list' = brackets . fsep . punctuate ","

    dedup ts =
        if M.null dups
        then list ts
        else parens $
             "let"<+>vcat [ev i<+>"="<+>ppT t|(i,t)<-defs] $$
             "in"<+>list' (zipWith entry ts is)
      where
        entry t i = maybe (ppT t) ev (M.lookup i dups)
        ev i = "e'"<>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]

convType = convType' False
convTypeA = convType' True

convType' atomic gId = if atomic then ppA else ppT
  where
    ppT = ppT' False
    ppT' loop t =
      case t of
        Table ti tv -> ppB ti <+> "->" <+> ppT tv
        _ -> ppB' loop t

    ppB = ppB' False
    ppB' loop t =
      case t of
        RecType rt -> rcon (map fst rt)<+>fsep (fields rt)
        App tf ta -> ppB tf <+> ppA ta
        FV [] -> pp "({-empty variant-})"
        _ -> ppA' loop 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 (qual m n)
        Q (m,n) -> gId (qual m n)
        _ -> {-trace (show t) $-} parens (ppT' True t)

    fields = map (ppA.snd) . sort . filter (not.isLockLabel.fst)

proj l = con ("proj_"++render 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)" $$
    enumAllInstance $$
    vcat (zipWith projection vs ls) $$
    to_rcon ls<+>"r"<+>"="<+>cn<+>fsep [parens (proj l<+>"r")|l<-ls] $$ ""
  where
    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 v l =
       hang ("instance"<+>"Has_"<>l<+>parens app<+>v<+>"where") 4
            (proj l<+>parens app<+>"="<+>v)

    enumAllInstance =
       hang ("instance"<+>ctx<+>"EnumAll"<+>parens app<+>"where") 4
            ("enumAll"<+>"="<+>enumCon cn n)
      where
        ctx = if n==0
              then empty
              else parens (fsep (punctuate "," ["EnumAll"<+>v|v<-vs]))<+>"=>"

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)) _)
       {- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
         ((S.singleton (m,n),argTypes ps),
          "data"<+>gId (qual m n)<+>"="<+>
               sep [fsep (punctuate " |" (map (param m) ps)),
                    pp "deriving (Eq,Ord,Show)"] $$
          hang ("instance EnumAll"<+>gId (qual m n)<+>"where") 4
               ("enumAll"<+>"="<+>sep (punctuate " ++" (map (enumParam m) ps)))
         )
      Ok (m,ResOper  _ (Just (L _ t)))
        | m==cPredef && n==cInts ->
           ((S.singleton (m,n),S.empty),
            "type"<+>gId (qual m n)<+>"n = Int")
        | otherwise ->
           ((S.singleton (m,n),paramTypes gr t),
            "type"<+>gId (qual m n)<+>"="<+>convType gId t)
      _ -> ((S.empty,S.empty),empty)
  where
    param m (n,ctx) = gId (qual m n)<+>[convTypeA 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 brackets name
    else parens $
         fsep ((name<+>"<$>"):punctuate " <*>" (replicate arity (pp "enumAll")))

qual :: ModuleName -> Ident -> Ident
qual m = prefixIdent (render m++"_")