content: {- |
  Module      :  $Id$
  Copyright   :  (c) K. Luettich, C. Maeder and Uni Bremen 2002-2009
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  portable
  
  generate ShATermConvertible instances
  -}
  
  module UserRulesHetCATS (hetcatsrules) where
  
  import Prelude hiding ((<>))
  
  import RuleUtils -- gives some examples
  import DataP
  import Text.PrettyPrint.HughesPJ
  import Data.List
  import Data.Maybe
  
  hetcatsrules :: [RuleDef]
  hetcatsrules =
    [ ("ShATermConvertible", shatermfn False, "", "", Nothing)
    , ("ShATermLG", shatermfn True, "", "", Nothing)
    , ("XmlContent", userRuleXmlNew, "Representation"
      , "encode terms as XML (HaXml>=1.14)", Nothing)
    , ("Binary", binaryfn False, "", "", Nothing)
    , ("BinaryLG", binaryfn True, "", "", Nothing)
    , ("Typeable", typeablefn, "", "", Nothing)
    , ("Json", jsonfn, "", "", Nothing)
    , ("XmlPickler", xmlpicklerfn, "", "", Nothing)
    , ("GetRange", getrangefn, "", "", Nothing)]
  
  -- useful helper things
  addPrime :: Doc -> Doc
  addPrime = (<> char '\'')
  
  ppCons' :: Body -> [Doc] -> Doc
  ppCons' b = fsep . (text (constructor b) :)
  
  xmlpicklerfn :: Data -> Doc
  xmlpicklerfn _ = empty
  
  -- XmlContent
  userRuleXmlNew :: Data -> Doc
  userRuleXmlNew dat =
    let cs = body dat             -- constructors
        cvs = mknss cs namesupply -- variables
    in
    instanceheader "HTypeable" dat $$
    block [toHTfn cs cvs dat] $$
    instanceheader "XmlContent" dat $$
    block (
      case cs of
        [c] -> text "parseContents = do"
               $$ nest 4 (text "{ inElementWith (flip isPrefixOf)"
                         <+> text (show (constructor c)) <+> text "$"
                         $$ parseFn True (head cvs) c
                         $$ text "}"
                         )
        _ -> text "parseContents = do"
              $$ nest 4 (text "{ e@(Elem t _ _) <- elementWith (flip isPrefixOf)"
                        <+> text (show (preorder cs (map constructor cs)))
                        $$ text "; case t of"
                        $$ nest 2 (text "_"
                                  $$ nest 2 (vcat (preorder cs
                                                         (zipWith (parseFn False)
                                                                  cvs cs))))
                        $$ text "}"
                        )
      : zipWith3 showsfn [0 ..] cvs cs)
  
  toHTfn :: [Body] -> [[Doc]] -> Data -> Doc
  toHTfn cs cvs dat =
    let typ = name dat
        fvs = vars dat
        pats = concat (zipWith mkpat cvs cs)
    in
    text "toHType v =" $$
    nest 4 (
      text "Defined" <+>
      fsep [ text "\"" <> text typ <> text "\""
           , bracketList (map text fvs)
           , bracketList (zipWith toConstr cvs cs)
           ]
      ) $$
    if null pats then empty
    else nest 2 (text "where") $$
         nest 4 (vcat (map (<+> text "= v") pats)) $$
         nest 4 (vcat (map (simplest typ (zip cvs cs)) fvs))
  
  namesupply :: [Doc]
  namesupply =
    [text [x, y] | x <- ['a' .. 'z'], y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
  
  mknss :: [Body] -> [a] -> [[a]]
  mknss [] _ = []
  mknss (c : cs) ns =
    let (thisns, rest) = splitAt (length (types c)) ns
    in thisns : mknss cs rest
  
  mkpat :: [Doc] -> Body -> [Doc]
  mkpat ns c =
    if null ns then []
    else [mypattern (constructor c) (types c) ns]
  
  
  toConstr :: [Doc] -> Body -> Doc
  toConstr ns c =
    let cn = constructor c
        ts = types c
        fvs = nub (concatMap deepvars ts)
    in
    text "Constr" <+>
    fsep [ text "\"" <> text cn <> text "\""
         , bracketList (map text fvs)
         , bracketList (map (text "toHType" <+>) ns)
         ]
    where
      deepvars (Arrow _ _) = []
      -- deepvars (Apply t1 t2)  = deepvars t1 ++ deepvars t2
      deepvars (LApply _ ts) = concatMap deepvars ts
      deepvars (Var s) = [s]
      deepvars (Con _) = []
      deepvars (Tuple ts) = concatMap deepvars ts
      deepvars (List t) = deepvars t
  
  simplest :: String -> [([Doc], Body)] -> String -> Doc
  simplest typ cs fv =
    let npats = [ (depth, (n, pat)) | (ns, c) <- cs
                                  , (n, t) <- zip ns (types c)
                                  , (depth, pat) <- [ findT fv t ]
                ]
        (_, (r, rpat)) =
            foldl closest (Nothing, error "free tyvar not found") npats
    in
    parens rpat <+> text "= toHType" <+> r
    where
      findT :: String -> Type -> (Maybe Int, Doc)
      findT v ty = case ty of
        Arrow _ _ ->
          (Nothing, error "can't derive Haskell2Xml/HTypeable for arrow type")
        LApply c ts
          | c == Con typ -> (Nothing, text "_")
          | otherwise -> let
              (_, cpat) = findT v c
              dpats = map (findT v) ts
              (ds, _) = unzip dpats
              in perhaps (combine ds)
                 $ cpat <+> bracketList (map (snd . uncurry perhaps) dpats)
                 <+> text "_"
        Var s -> perhaps (if v == s then Just 0 else Nothing) (text v)
        Con s -> (Nothing, text "Defined" <+> text "\"" <> text s <> text "\"")
        Tuple ts -> let
          dpats = map (findT v) ts
          (ds, _) = unzip dpats
          in perhaps (combine ds)
             $ text "Tuple" <+> bracketList (map (snd . uncurry perhaps) dpats)
        List t -> let (d, pat) = findT v t
          in perhaps (inc d) (text "List" <+> parens pat)
      perhaps jn doc = (jn, maybe (text "_") (const doc) jn)
      combine ds = let js = catMaybes ds in
          if null js then Nothing else inc (Just (minimum js))
      inc = fmap (+ 1)
      closest :: (Maybe Int, a) -> (Maybe Int, a) -> (Maybe Int, a)
      closest a b = case (a, b) of
        ((Nothing, _), (Just _, _)) -> b
        ((Just n, _), (Just m, _)) | m >= n -> b
        _ -> a
  
  
  -- showsfn (n = index) (ns = variables) (cn = constructor body)
  showsfn :: Int -> [Doc] -> Body -> Doc
  showsfn n ns cn =
    let cons = constructor cn
        typ = types cn
        sc = parens (text "showConstr" <+> text (show n) <+>
                       parens (text "toHType" <+> text "v"))
        cfn [] = text "[]"
        cfn [x] = parens (text "toContents" <+> x)
        cfn xs = parens
          (text "concat" <+> bracketList (map (text "toContents" <+>) xs))
    in
    text "toContents" <+>
    text "v@" <> mypattern cons typ ns <+> text "=" $$
    nest 4 (text "[mkElemC" <+> sc <+> cfn ns <> text "]")
  
  preorder :: [Body] -> [b] -> [b]
  preorder cs =
      map snd . sortBy (\ (b, _) (a, _) -> compare a b)
      . zip (map constructor cs)
  
  
  -- parseFn (ns = variables) (cn = constructor body)
  parseFn :: Bool -> t -> Body -> Doc
  parseFn single _ cn =
    let cons = constructor cn
        arity = length (types cn)
        intro = if single then empty
                else text "|" <+> text (show cons)
                     <+> text "`isPrefixOf` t -> interior e $"
    in
    case arity of
      0 -> intro <+> nest 8 (text "return" <+> text cons)
      1 -> intro <+> nest 8 (text "fmap" <+> text cons <+> text "parseContents")
      _ -> intro $$ nest 8 (text "return" <+> text cons
                            <+> fsep (replicate arity
                                      (text "`apply` parseContents")))
  
  instanceheader :: String -> Data -> Doc
  instanceheader cls dat =
    let fv = vars dat
        tycon = name dat
        ctx = map (\ v -> text cls <+> text v)
        parenSpace = parens . hcat . sepWith space
    in
    hsep [ text "instance"
         , opt fv (\ v -> parenList (ctx v) <+> text "=>")
         , text cls
         , opt1 (texts (tycon : fv)) parenSpace id
         , text "where"
         ]
  
  mypattern :: Constructor -> [a] -> [Doc] -> Doc
  mypattern c l ns =
    if null l then text c else parens (hsep (text c : take (length l) ns))
  
  -- begin of GetRange derivation
  getrangefn :: Data -> Doc
  getrangefn dat =
         instanceSkeleton "GetRange" [] dat
         $$ (if any (elem posLC . types) (body dat) then
                text "  getRange x = case x of"
                $$ block (map makeGetPosFn $ body dat)
            else text "  getRange = const nullRange")
         $$ text "  rangeSpan x = case x of"
         $$ block (map makeSpanFn $ body dat)
  
  posLC :: Type
  posLC = Con "Range"
  
  makeGetPosFn :: Body -> Doc
  makeGetPosFn b =
         let (r, vs) = mapAccumL accFun True (types b)
             p = text "p"
             accFun f t =
                 if f && t == posLC then (False, p) else (f, text "_")
         in ppCons' b vs <+> rArrow <+> if r then text "nullRange" else p
  
  makeSpanFn :: Body -> Doc
  makeSpanFn b =
    let vs = varNames $ types b
    in ppCons' b vs <+> rArrow
        <+> if null vs then text "[]" else
         text "joinRanges" <+> bracketList (map (text "rangeSpan" <+>) vs)
  
  -- end of GetRange derivation
  
  binaryfn :: Bool -> Data -> Doc
  binaryfn forLG dat =
    let dn = name dat
        cs = body dat
        moreCs = length cs > 1
        u = text "u"
    in instanceSkeleton (if forLG then "BinaryLG" else "Binary")
           [] dat
       $$ text ("  put" ++ (if forLG then "LG" else "") ++ " xv = case xv of")
       $$ block (zipWith (makePutBinary forLG moreCs) cs [0 .. ])
       $$ text ("  get" ++ (if forLG then "LG lg" else "") ++ " = "
                ++ if moreCs then "getWord8 >>= \\ tag -> case tag of" else "do")
       $$ block (zipWith (makeGetBinary forLG moreCs) cs [0 .. ] ++
         [u <+> rArrow <+> text "fromBinaryError"
           <+> doubleQuotes (text dn) <+> u | moreCs])
  
  makePutBinary :: Bool -> Bool -> Body -> Int -> Doc
  makePutBinary forLG moreCs b i =
      let vs = varNames $ types b
          putComp v = text ("put" ++ if forLG then "LG" else "") <+> v
          hl | moreCs = text $ "putWord8 " ++ show i
             | null vs = text "return ()"
             | otherwise = empty
      in ppCons' b vs <+> rArrow <+> (if null vs then hl else text "do")
            $$ if null vs then empty else nest 2 . vcat $ hl : map putComp vs
  
  makeGetBinary :: Bool -> Bool -> Body -> Int -> Doc
  makeGetBinary forLG moreCs b i =
      let vs = varNames $ types b
          getComp v =
            v <+> lArrow <+> text ("get" ++ if forLG then "LG lg" else "")
          rl = text ("return" ++ if null vs then "" else " $") <+> ppCons' b vs
      in (if moreCs then text (show i) <+> rArrow else empty)
         <+> (if null vs then rl else if moreCs then text "do" else empty)
         $$ if null vs then empty else nest 2 . vcat $ map getComp vs ++ [rl]
  
  -- begin of ShATermConvertible derivation
  shatermfn :: Bool -> Data -> Doc
  shatermfn forLG dat =
    let dn = name dat
        cs = body dat
        u = text "u"
    in instanceSkeleton (if forLG then "ShATermLG" else "ShATermConvertible")
           [] dat
       $$ text ("  toShATerm" ++ (if forLG then "LG" else "Aux")
                ++ " att0 xv = case xv of")
       $$ block (map (makeToShATerm forLG) cs)
       $$ text ("  fromShATerm" ++ (if forLG then "LG lg" else "Aux")
                   ++ " ix att0 = case getShATerm ix att0 of")
       $$ block (map (makeFromShATerm forLG) cs ++
                 [u <+> rArrow <+> text "fromShATermError"
                  <+> doubleQuotes (text dn) <+> u])
  
  att :: Int -> Doc
  att i = text $ "att" ++ show (i :: Int)
  
  closeBraces :: [b] -> Doc
  closeBraces = hcat . map (const $ char '}')
  
  pair :: Doc -> Doc -> Doc
  pair f s = parens $ f <> comma <+> s
  
  makeToShATerm :: Bool -> Body -> Doc
  makeToShATerm forLG b =
      let ts = types b
          tooLong = length (constructor b) > 15
          vs = varNames ts
          rl = text "return $ addATerm (ShAAppl" <+>
              doubleQuotes (text (constructor b)) <+>
              bracketList (varNames' ts) <+> text "[])" <+>
              att (length ts)
      in ppCons' b vs <+> rArrow <+>
         (if null vs then if tooLong then empty else rl else text "do")
         $$ if null vs then if tooLong then nest 2 rl else empty
            else nest 2 . vcat $ zipWith (childToShATerm forLG) vs [0 :: Int ..]
                     ++ [rl]
  
  childToShATerm :: Bool -> Doc -> Int -> Doc
  childToShATerm forLG v i = pair (att $ i + 1) (addPrime v) <+> lArrow
      <+> text ("toShATerm" ++ if forLG then "LG'" else "'") <+> att i <+> v
  
  makeFromShATerm :: Bool -> Body -> Doc
  makeFromShATerm forLG b =
      let ts = types b
          vs = varNames ts
          childFromShATerm v i =
            text ("case fromShATerm" ++ if forLG then "LG' lg" else "'")
            <+> v <+> att i <+> text "of"
            $$ text "{" <+> pair (att $ i + 1) (addPrime v) <+> rArrow
          rl = pair (att $ length ts) (ppCons' b $ varNames' ts)
               <+> closeBraces ts
      in text "ShAAppl" <+> doubleQuotes (text $ constructor b) <+>
         bracketList vs <+> text "_" <+> rArrow
         <+> (if null vs then rl else empty)
         $$ if null vs then empty else
            nest 2 . vcat $ zipWith childFromShATerm vs [0 :: Int ..] ++ [rl]
  -- end of ATermConvertible derivation
  
  typeablefn :: Data -> Doc
  typeablefn dat =
      let vs = vars dat
          dn = name dat
          ntext str = str ++ if null vs then "" else show $ length vs
          stext = text ("deriving instance Typeable " ++ dn)
      in if null vs then stext else
         text "#if __GLASGOW_HASKELL__ < 708" $$
         text ("deriving instance " ++ ntext "Typeable" ++ " " ++ dn)
         $$ text "#else" $$ stext $$ text "#endif"
  
  
  jsonfn :: Data ->Doc
  jsonfn dat =
      let vs = vars dat
          dn = name dat
          typ = if null vs then text dn else parens . hsep . fmap text $ (dn : vs)
          gen = text "deriving instance GHC.Generics.Generic" <+> typ
  
          datC s = dat { constraints = constraints dat ++ map (\x -> (s, x)) vs }
      in gen
        $+$ instanceSkeleton "Data.Aeson.ToJSON" [] dat
        $+$ instanceSkeleton "Data.Aeson.FromJSON" [] dat
  