<commit_before>-----------------------------------------------------------------------------
--
-- Module      :  Language.Elm.TH.Json
-- Copyright   :  Copyright: (c) 2011-2013 <NAME>
-- License     :  BSD3
--
-- Maintainer  :  <EMAIL>
-- Stability   :  experimental
-- Portability :  portable
--
-- |
--
-----------------------------------------------------------------------------
module Language.Elm.TH.Json where

{-# LANGUAGE TemplateHaskell, QuasiQuotes, MultiWayIf #-}

import Language.Haskell.TH.Syntax

import Data.Aeson.TH


import qualified SourceSyntax.Module as M
import qualified SourceSyntax.Declaration as D
import qualified SourceSyntax.Expression as E
import qualified SourceSyntax.Literal as L
import qualified SourceSyntax.Location as Lo
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Type as T

import Data.List (isPrefixOf)

import Language.Haskell.TH.Desugar.Sweeten
import Language.Haskell.TH.Desugar

import Language.Elm.TH.Util


--import Parse.Expression (makeFunction)

import Control.Applicative

import Control.Monad.State (StateT)
import qualified Control.Monad.State as S

--Helper function to apply arguments to a function
applyArgs :: Exp -> [Exp] -> Exp
applyArgs fun args = foldl (\ accumFun nextArg -> AppE accumFun nextArg) fun args

--General helper functions
jsonArgName :: Name
jsonArgName = mkName "jsonArg"

jsonArgPat :: Pat
jsonArgPat = VarP jsonArgName

fromJsonName :: Name -> Name
fromJsonName name = mkName $ "fromJson_" ++ nameToString name

-- | Given a type, and an expression for an argument of type Json
-- return the expression which applies the proper fromJson function to that expression
fromJsonForType :: Type -> SQ Exp
fromJsonForType t = do
  --lookup t in state
  dec <- error "TODO implement dec lookup from type"
  return $ error "TODO implement dec lookup from type"

-- |Given a type declaration, generate the function declaration
-- Which takes a Json object to a value of that type
fromJsonForDec :: Dec -> SQ Dec

fromJsonForDec dec@(DataD _ name _ ctors _deriving) = do
  let argTagExpression = error "TODO add expr for getting tag from arg"
  ctorMatches <- mapM fromMatchForCtor ctors
  let fnExp = CaseE argTagExpression ctorMatches
  let argPat = jsonArgPat
  let fnName = fromJsonName name
  let fnBody = NormalB fnExp
  let fnClause = Clause [argPat] fnBody []
  return $ FunD fnName [fnClause]

fromJsonForDec (NewtypeD cxt name tyBindings  ctor nameList) = 
  fromJsonForDec $ DataD cxt name tyBindings [ctor] nameList
  
fromMatchForCtor :: Con -> SQ Match

fromMatchForCtor (NormalC name strictTypes) = do
  let types = map snd strictTypes
  let leftHandSide = LitP $ StringL $ nameToString name
  
  let ctorExp = VarE name
  argExps <- mapM fromJsonForType types
  let rightHandSide = NormalB $ applyArgs ctorExp argExps
  return $ Match leftHandSide rightHandSide []

fromMatchForCtor _ = error "TODO implement constructor match generation"

makeFromJson = error "TODO implement making json"

makeToJson = error "TODO implement making json"<commit_msg>Skeleton for toJson<commit_after>-----------------------------------------------------------------------------
--
-- Module      :  Language.Elm.TH.Json
-- Copyright   :  Copyright: (c) 2011-2013 <NAME>
-- License     :  BSD3
--
-- Maintainer  :  <EMAIL>
-- Stability   :  experimental
-- Portability :  portable
--
-- |
--
-----------------------------------------------------------------------------
module Language.Elm.TH.Json where

{-# LANGUAGE TemplateHaskell, QuasiQuotes, MultiWayIf #-}

import Language.Haskell.TH.Syntax

import Data.Aeson.TH


import qualified SourceSyntax.Module as M
import qualified SourceSyntax.Declaration as D
import qualified SourceSyntax.Expression as E
import qualified SourceSyntax.Literal as L
import qualified SourceSyntax.Location as Lo
import qualified SourceSyntax.Pattern as P
import qualified SourceSyntax.Type as T

import Data.List (isPrefixOf)

import Language.Haskell.TH.Desugar.Sweeten
import Language.Haskell.TH.Desugar

import Language.Elm.TH.Util


--import Parse.Expression (makeFunction)

import Control.Applicative

import Control.Monad.State (StateT)
import qualified Control.Monad.State as S

--Helper function to apply arguments to a function
applyArgs :: Exp -> [Exp] -> Exp
applyArgs fun args = foldl (\ accumFun nextArg -> AppE accumFun nextArg) fun args


-- | Filter function to test if a dec is a data
-- Also filters out decs which types that can't be serialized, such as functions
isData :: Dec -> Bool
isData dec = (isData' dec) && (canSerial dec) 
  where
    isData' DataD{} = True
    isData' NewtypeD{} = True
    isData' TySynD{} = True
    isData' _ = False
    
    canSerial (DataD _ _ _ ctors _) = all canSerialCtor ctors
    canSerial (NewtypeD _ _ _ ctor _) = canSerialCtor ctor
    canSerial (TySynD _ _ ty) = canSerialType ty
    --can't serialize if type variables --TODO is this true?
    canSerial _ = False
    
    canSerialCtor (NormalC _ types) = all (canSerialType) (map snd types)
    canSerialCtor (RecC _ types) = all (canSerialType) (map (\(_,_,c)->c) types)
    
    canSerialType (ArrowT) = False
    canSerialType t = all canSerialType (subTypes t)

--General helper functions
jsonArgName :: Name
jsonArgName = mkName "jsonArg"

jsonArgPat :: Pat
jsonArgPat = VarP jsonArgName

jsonArgExp :: Exp
jsonArgExp = VarE jsonArgName

fromJsonName :: Name -> Name
fromJsonName name = mkName $ "toJson_" ++ nameToString name

toJsonName :: Name -> Name
toJsonName name = mkName $ "toJson_" ++ nameToString name

-- | Given a type, and an expression for an argument of type Json
-- return the expression which applies the proper fromJson function to that expression
fromJsonForType :: Type -> SQ Exp
fromJsonForType t = do
  --lookup t in state
  dec <- error "TODO implement dec lookup from type"
  return $ error "TODO implement dec lookup from type"

-- |Given a type declaration, generate the function declaration
-- Which takes a Json object to a value of that type
fromJsonForDec :: Dec -> SQ Dec

fromJsonForDec dec@(DataD _ name _ ctors _deriving) = do
  let argTagExpression = error "TODO add expr for getting tag from arg"
  ctorMatches <- mapM fromMatchForCtor ctors
  let fnExp = CaseE argTagExpression ctorMatches
  let argPat = jsonArgPat
  let fnName = fromJsonName name
  let fnBody = NormalB fnExp
  let fnClause = Clause [argPat] fnBody []
  return $ FunD fnName [fnClause]

fromJsonForDec (NewtypeD cxt name tyBindings  ctor nameList) = 
  fromJsonForDec $ DataD cxt name tyBindings [ctor] nameList
  
fromMatchForCtor :: Con -> SQ Match

fromMatchForCtor (NormalC name strictTypes) = do
  let types = map snd strictTypes
  let leftHandSide = LitP $ StringL $ nameToString name
  
  let ctorExp = VarE name
  argExps <- mapM fromJsonForType types
  let rightHandSide = NormalB $ applyArgs ctorExp argExps
  return $ Match leftHandSide rightHandSide []

fromMatchForCtor _ = error "TODO implement constructor match generation"

makeFromJson :: [Dec] -> SQ [Dec]
makeFromJson allDecs = do
  let decs = filter isData allDecs
  mapM fromJsonForDec decs
  
  
  
  
  

makeToJson = error "TODO implement making json"

toJsonForType :: Type -> SQ Exp
toJsonForType t = error "TODO implement toJson for types"

toJsonForDec :: Dec -> SQ Dec
toJsonForDec dec@(DataD _ name _ ctors _deriving) = do
  let argPat = jsonArgPat
  let argExp = jsonArgExp
  ctorMatches <- mapM toMatchForCtor ctors
  
  let fnExp = CaseE jsonArgExp ctorMatches
  
  let fnName = toJsonName name
  let fnBody = NormalB fnExp
  let fnClause = Clause [argPat] fnBody []
  return $ FunD fnName [fnClause]
  
toMatchForCtor :: Con -> SQ Match
toMatchForCtor con = error "TODO to matches for ctors"
{'fraction_non_alphanumeric': 0.11218944099378882, 'fraction_numerical': 0.002329192546583851, 'mean_word_length': 3.1959826275787186, 'pattern_counts': {'":': 0, '<': 14, '<?xml version=': 0, '>': 28, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '489721', 'n_tokens_mistral': 2335, 'n_tokens_neox': 2270, 'n_words': 826}