content: -- | Translate concrete syntax to Haskell
  module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) 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,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.Infra.Option
  import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
  import GF.Haskell
  import Debug.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
    ]
  
  -- | 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)
    where
      nl = Comment ""
      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
  
  --  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))
        where
          abs = tcon0 (prefixIdent "A." (gId c))
          lin = tcon0 lc
          lf = prefixIdent "lin" c
          lc = prefixIdent "Lin" 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]
  
      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)
  
      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))]
        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
  
  
  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 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)
  
          pre (K s) = [lit s]
          pre (Strs ts) = concatMap pre ts
          pre (EPatt p) = pat p
          pre t = error $ "pre "++show t
  
          pat (PString s) = [lit s]
          pat (PAlt p1 p2) = pat p1++pat p2
          pat p = error $ "pat "++show p
  
      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
  rcon' = identS . rcon_name
  rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)])
  to_rcon = con . to_rcon'
  to_rcon' = ("to_"++) . rcon_name
  
  recordType ls =
      Data lhs [app] ["Eq","Ord","Show"]:
      enumAllInstance:
      zipWith projection vs ls ++
      [Eqn (identS (to_rcon' ls),[VarP r])
           (foldl Ap (Var cn) [Var (identS (proj' l)) `Ap` Var r|l<-ls])]
    where
      r = identS "r"
      cn = rcon' ls
   -- Not all record labels are syntactically correct as type variables in Haskell
   -- app = cn<+>ls
      lhs = ConAp cn vs -- don't reuse record labels
      app = fmap TId lhs
      tapp = foldl TAp (TId cn) (map TId vs)
      vs = [identS ('t':show i)|i<-[1..n]]
      n = length ls
  
      projection v l = Instance [] (TId name `TAp` tapp `TAp` TId v)
                                [((prj,[papp]),Var v)]
       where
         name = identS ("Has_"++render l)
         prj = identS (proj' l)
         papp = ConP cn (map VarP vs)
  
      enumAllInstance =
         Instance ctx (tEnumAll `TAp` tapp)[(lhs0 "enumAll",enumCon cn n)]
        where
          ctx =  [tEnumAll `TAp` TId v|v<-vs]
          tEnumAll = TId (identS "EnumAll")
  
  labelClass l =
      Class [] (ConAp name [r,a]) [([r],[a])]
            [(identS (proj' l),TId r `Fun` TId a)]
    where
      name = identS ("Has_"++render 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)
      else foldl ap (single (Var name)) (replicate arity (Const "enumAll"))
    where
      ap (List [f]) a = Op f "<$>" a
      ap f a = Op f "<*>" a
  
  qual :: ModuleName -> Ident -> Ident
  qual m = prefixIdent (render m++"_")
  