module Hydra.Langs.Haskell.Coder (moduleToHaskell) where

import Hydra.Kernel
import Hydra.Adapters
import Hydra.Langs.Haskell.Language
import Hydra.Langs.Haskell.Utils
import Hydra.Dsl.Terms
import Hydra.Tools.Serialization
import Hydra.Langs.Haskell.Serde
import Hydra.Langs.Haskell.Settings
import qualified Hydra.Langs.Haskell.Ast as H
import qualified Hydra.Lib.Strings as Strings
import qualified Hydra.Dsl.Types as Types
import Hydra.Lib.Io

import qualified Control.Monad as CM
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Maybe as Y
import Hydra.Rewriting (removeTypeAnnotations, removeTermAnnotations)


adaptTypeToHaskellAndEncode :: Namespaces -> Type -> Flow Graph H.Type
adaptTypeToHaskellAndEncode :: Namespaces -> Type -> Flow Graph Type
adaptTypeToHaskellAndEncode Namespaces
namespaces = Language -> (Type -> Flow Graph Type) -> Type -> Flow Graph Type
forall t.
Language -> (Type -> Flow Graph t) -> Type -> Flow Graph t
adaptAndEncodeType Language
haskellLanguage (Namespaces -> Type -> Flow Graph Type
encodeType Namespaces
namespaces)

constantDecls :: Graph -> Namespaces -> Name -> Type -> [H.DeclarationWithComments]
constantDecls :: Graph -> Namespaces -> Name -> Type -> [DeclarationWithComments]
constantDecls Graph
g Namespaces
namespaces name :: Name
name@(Name FilePath
nm) Type
typ = if Bool
useCoreImport
    then Name -> (FilePath, FilePath) -> DeclarationWithComments
toDecl (FilePath -> Name
Name FilePath
"hydra/core.Name") (FilePath, FilePath)
nameDeclDeclarationWithComments
-> [DeclarationWithComments] -> [DeclarationWithComments]
forall a. a -> [a] -> [a]
:(Name -> (FilePath, FilePath) -> DeclarationWithComments
toDecl (FilePath -> Name
Name FilePath
"hydra/core.Name") ((FilePath, FilePath) -> DeclarationWithComments)
-> [(FilePath, FilePath)] -> [DeclarationWithComments]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FilePath, FilePath)]
fieldDecls)
    else []
  where
    lname :: FilePath
lname = Name -> FilePath
localNameOfEager Name
name
    toDecl :: Name -> (FilePath, FilePath) -> DeclarationWithComments
toDecl Name
n (FilePath
k, FilePath
v) = Declaration -> Maybe FilePath -> DeclarationWithComments
H.DeclarationWithComments Declaration
decl Maybe FilePath
forall a. Maybe a
Nothing
      where
        decl :: Declaration
decl = ValueBinding -> Declaration
H.DeclarationValueBinding (ValueBinding -> Declaration) -> ValueBinding -> Declaration
forall a b. (a -> b) -> a -> b
$ ValueBinding_Simple -> ValueBinding
H.ValueBindingSimple (ValueBinding_Simple -> ValueBinding)
-> ValueBinding_Simple -> ValueBinding
forall a b. (a -> b) -> a -> b
$ Pattern
-> RightHandSide -> Maybe LocalBindings -> ValueBinding_Simple
H.ValueBinding_Simple Pattern
pat RightHandSide
rhs Maybe LocalBindings
forall a. Maybe a
Nothing
        pat :: Pattern
pat = Name -> [Pattern] -> Pattern
applicationPattern (FilePath -> Name
simpleName FilePath
k) []
        rhs :: RightHandSide
rhs = Expression -> RightHandSide
H.RightHandSide (Expression -> RightHandSide) -> Expression -> RightHandSide
forall a b. (a -> b) -> a -> b
$ Expression_Application -> Expression
H.ExpressionApplication (Expression_Application -> Expression)
-> Expression_Application -> Expression
forall a b. (a -> b) -> a -> b
$ Expression -> Expression -> Expression_Application
H.Expression_Application
          (Name -> Expression
H.ExpressionVariable (Name -> Expression) -> Name -> Expression
forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> Name
elementReference Namespaces
namespaces Name
n)
          (Literal -> Expression
H.ExpressionLiteral (Literal -> Expression) -> Literal -> Expression
forall a b. (a -> b) -> a -> b
$ FilePath -> Literal
H.LiteralString FilePath
v)
    nameDecl :: (FilePath, FilePath)
nameDecl = (FilePath
"_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
lname, FilePath
nm)
    fieldsOf :: Type -> [FieldType]
fieldsOf Type
t = case Type -> Type
stripType Type
t of
      TypeRecord RowType
rt -> RowType -> [FieldType]
rowTypeFields RowType
rt
      TypeUnion RowType
rt -> RowType -> [FieldType]
rowTypeFields RowType
rt
      Type
_ -> []
    fieldDecls :: [(FilePath, FilePath)]
fieldDecls = FieldType -> (FilePath, FilePath)
toConstant (FieldType -> (FilePath, FilePath))
-> [FieldType] -> [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> [FieldType]
fieldsOf (([Name], Type) -> Type
forall a b. (a, b) -> b
snd (([Name], Type) -> Type) -> ([Name], Type) -> Type
forall a b. (a -> b) -> a -> b
$ Graph -> Type -> ([Name], Type)
unpackLambdaType Graph
g Type
typ)
    toConstant :: FieldType -> (FilePath, FilePath)
toConstant (FieldType (Name FilePath
fname) Type
_) = (FilePath
"_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
lname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
fname, FilePath
fname)

constructModule :: Namespaces
  -> Module
  -> M.Map Type (Coder Graph Graph Term H.Expression)
  -> [(Element, TypedTerm)] -> Flow Graph H.Module
constructModule :: Namespaces
-> Module
-> Map Type (Coder Graph Graph Term Expression)
-> [(Element, TypedTerm)]
-> Flow Graph Module
constructModule Namespaces
namespaces Module
mod Map Type (Coder Graph Graph Term Expression)
coders [(Element, TypedTerm)]
pairs = do
    Graph
g <- Flow Graph Graph
forall s. Flow s s
getState
    [DeclarationWithComments]
decls <- [[DeclarationWithComments]] -> [DeclarationWithComments]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ([[DeclarationWithComments]] -> [DeclarationWithComments])
-> Flow Graph [[DeclarationWithComments]]
-> Flow Graph [DeclarationWithComments]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Element, TypedTerm) -> Flow Graph [DeclarationWithComments])
-> [(Element, TypedTerm)] -> Flow Graph [[DeclarationWithComments]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM (Graph
-> (Element, TypedTerm) -> Flow Graph [DeclarationWithComments]
forall {p}.
p -> (Element, TypedTerm) -> Flow Graph [DeclarationWithComments]
createDeclarations Graph
g) [(Element, TypedTerm)]
pairs
    let mc :: Maybe FilePath
mc = Module -> Maybe FilePath
moduleDescription Module
mod
    Module -> Flow Graph Module
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Module -> Flow Graph Module) -> Module -> Flow Graph Module
forall a b. (a -> b) -> a -> b
$ Maybe ModuleHead -> [Import] -> [DeclarationWithComments] -> Module
H.Module (ModuleHead -> Maybe ModuleHead
forall a. a -> Maybe a
Just (ModuleHead -> Maybe ModuleHead) -> ModuleHead -> Maybe ModuleHead
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> ModuleName -> [Export] -> ModuleHead
H.ModuleHead Maybe FilePath
mc (FilePath -> ModuleName
importName (FilePath -> ModuleName) -> FilePath -> ModuleName
forall a b. (a -> b) -> a -> b
$ Namespace -> FilePath
h (Namespace -> FilePath) -> Namespace -> FilePath
forall a b. (a -> b) -> a -> b
$ Module -> Namespace
moduleNamespace Module
mod) []) [Import]
imports [DeclarationWithComments]
decls
  where
    h :: Namespace -> FilePath
h (Namespace FilePath
name) = FilePath
name

    createDeclarations :: p -> (Element, TypedTerm) -> Flow Graph [DeclarationWithComments]
createDeclarations p
g pair :: (Element, TypedTerm)
pair@(Element
el, TypedTerm Term
term Type
typ) = do
      if Type -> Bool
isType Type
typ
        then Namespaces
-> Element -> Term -> Flow Graph [DeclarationWithComments]
toTypeDeclarations Namespaces
namespaces Element
el Term
term
        else do
          DeclarationWithComments
d <- Map Type (Coder Graph Graph Term Expression)
-> Namespaces
-> (Element, TypedTerm)
-> Flow Graph DeclarationWithComments
toDataDeclaration Map Type (Coder Graph Graph Term Expression)
coders Namespaces
namespaces (Element, TypedTerm)
pair
          [DeclarationWithComments] -> Flow Graph [DeclarationWithComments]
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return [DeclarationWithComments
d]

    importName :: FilePath -> ModuleName
importName FilePath
name = FilePath -> ModuleName
H.ModuleName (FilePath -> ModuleName) -> FilePath -> ModuleName
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
L.intercalate FilePath
"." (FilePath -> FilePath
capitalize (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FilePath -> [FilePath]
Strings.splitOn FilePath
"/" FilePath
name)
    imports :: [Import]
imports = [Import]
domainImports [Import] -> [Import] -> [Import]
forall a. [a] -> [a] -> [a]
++ [Import]
standardImports
      where
        domainImports :: [Import]
domainImports = (Namespace, ModuleName) -> Import
toImport ((Namespace, ModuleName) -> Import)
-> [(Namespace, ModuleName)] -> [Import]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Namespace ModuleName -> [(Namespace, ModuleName)]
forall k a. Map k a -> [(k, a)]
M.toList (Namespaces -> Map Namespace ModuleName
namespacesMapping Namespaces
namespaces)
          where
            toImport :: (Namespace, ModuleName) -> Import
toImport (Namespace FilePath
name, ModuleName
alias) = Bool
-> ModuleName -> Maybe ModuleName -> Maybe Import_Spec -> Import
H.Import Bool
True (FilePath -> ModuleName
importName FilePath
name) (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
alias) Maybe Import_Spec
forall a. Maybe a
Nothing
        standardImports :: [Import]
standardImports = (FilePath, Maybe FilePath) -> Import
toImport ((FilePath, Maybe FilePath) -> Import)
-> [(FilePath, Maybe FilePath)] -> [Import]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [
            (FilePath
"Data.Int", Maybe FilePath
forall a. Maybe a
Nothing),
            (FilePath
"Data.List", FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"L"),
            (FilePath
"Data.Map", FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"M"),
            (FilePath
"Data.Set", FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"S")]
          where
            toImport :: (FilePath, Maybe FilePath) -> Import
toImport (FilePath
name, Maybe FilePath
alias) = Bool
-> ModuleName -> Maybe ModuleName -> Maybe Import_Spec -> Import
H.Import Bool
False (FilePath -> ModuleName
H.ModuleName FilePath
name) (FilePath -> ModuleName
H.ModuleName (FilePath -> ModuleName) -> Maybe FilePath -> Maybe ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
alias) Maybe Import_Spec
forall a. Maybe a
Nothing

encodeFunction :: Namespaces -> Function -> Flow Graph H.Expression
encodeFunction :: Namespaces -> Function -> Flow Graph Expression
encodeFunction Namespaces
namespaces Function
fun = case Function
fun of
    FunctionElimination Elimination
e -> case Elimination
e of
      EliminationList Term
fun -> do
        let lhs :: Expression
lhs = FilePath -> Expression
hsvar FilePath
"L.foldl"
        Expression
rhs <- Namespaces -> Term -> Flow Graph Expression
encodeTerm Namespaces
namespaces Term
fun
        Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Expression -> Expression -> Expression
hsapp Expression
lhs Expression
rhs
      EliminationWrap Name
name -> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Name -> Expression
H.ExpressionVariable (Name -> Expression) -> Name -> Expression
forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> Name
elementReference Namespaces
namespaces (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$
        Namespace -> FilePath -> Name
qname (Maybe Namespace -> Namespace
forall a. HasCallStack => Maybe a -> a
Y.fromJust (Maybe Namespace -> Namespace) -> Maybe Namespace -> Namespace
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Namespace
namespaceOfEager Name
name) (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
newtypeAccessorName Name
name
      EliminationOptional (OptionalCases Term
nothing Term
just) -> do
        CaseRhs
nothingRhs <- Expression -> CaseRhs
H.CaseRhs (Expression -> CaseRhs)
-> Flow Graph Expression -> Flow Graph CaseRhs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespaces -> Term -> Flow Graph Expression
encodeTerm Namespaces
namespaces Term
nothing
        let nothingAlt :: Alternative
nothingAlt = Pattern -> CaseRhs -> Maybe LocalBindings -> Alternative
H.Alternative (Name -> Pattern
H.PatternName (Name -> Pattern) -> Name -> Pattern
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
rawName FilePath
"Nothing") CaseRhs
nothingRhs Maybe LocalBindings
forall a. Maybe a
Nothing
        Alternative
justAlt <- do
          -- Note: some of the following could be brought together with FunctionCases
          FilePath
v0 <- (\Int
i -> FilePath
"v" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i) (Int -> FilePath) -> Flow Graph Int -> Flow Graph FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Flow Graph Int
forall s. FilePath -> Flow s Int
nextCount FilePath
"haskellVar"
          let rhsTerm :: Term
rhsTerm = Term -> Term
simplifyTerm (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ Term -> Term -> Term
apply Term
just (FilePath -> Term
var FilePath
v0)
          let v1 :: FilePath
v1 = if Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member (FilePath -> Name
Name FilePath
v0) (Set Name -> Bool) -> Set Name -> Bool
forall a b. (a -> b) -> a -> b
$ Term -> Set Name
freeVariablesInTerm Term
rhsTerm then FilePath
v0 else FilePath
ignoredVariable
          let lhs :: Pattern
lhs = Name -> [Pattern] -> Pattern
applicationPattern (FilePath -> Name
rawName FilePath
"Just") [Name -> Pattern
H.PatternName (Name -> Pattern) -> Name -> Pattern
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
rawName FilePath
v1]
          CaseRhs
rhs <- Expression -> CaseRhs
H.CaseRhs (Expression -> CaseRhs)
-> Flow Graph Expression -> Flow Graph CaseRhs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespaces -> Term -> Flow Graph Expression
encodeTerm Namespaces
namespaces Term
rhsTerm
          Alternative -> Flow Graph Alternative
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Alternative -> Flow Graph Alternative)
-> Alternative -> Flow Graph Alternative
forall a b. (a -> b) -> a -> b
$ Pattern -> CaseRhs -> Maybe LocalBindings -> Alternative
H.Alternative Pattern
lhs CaseRhs
rhs Maybe LocalBindings
forall a. Maybe a
Nothing
        Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ FilePath -> Expression -> Expression
hslambda FilePath
"x" (Expression -> Expression) -> Expression -> Expression
forall a b. (a -> b) -> a -> b
$ Expression_Case -> Expression
H.ExpressionCase (Expression_Case -> Expression) -> Expression_Case -> Expression
forall a b. (a -> b) -> a -> b
$ Expression -> [Alternative] -> Expression_Case
H.Expression_Case (FilePath -> Expression
hsvar FilePath
"x") [Alternative
nothingAlt, Alternative
justAlt]
      EliminationProduct (TupleProjection Int
arity Int
idx) -> if Int
arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
        then Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ FilePath -> Expression
hsvar (FilePath -> Expression) -> FilePath -> Expression
forall a b. (a -> b) -> a -> b
$ if Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then FilePath
"fst" else FilePath
"snd"
        else FilePath -> Flow Graph Expression
forall a. FilePath -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"Eliminations for tuples of arity > 2 are not supported yet in the Haskell coder"
      EliminationRecord (Projection Name
dn Name
fname) -> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Name -> Expression
H.ExpressionVariable (Name -> Expression) -> Name -> Expression
forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> Name -> Name
recordFieldReference Namespaces
namespaces Name
dn Name
fname
      EliminationUnion (CaseStatement Name
dn Maybe Term
def [Field]
fields) -> FilePath -> Expression -> Expression
hslambda FilePath
"x" (Expression -> Expression)
-> Flow Graph Expression -> Flow Graph Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Flow Graph Expression
caseExpr -- note: could use a lambda case here
        where
          caseExpr :: Flow Graph Expression
caseExpr = do
            RowType
rt <- Flow Graph RowType -> Flow Graph RowType
forall x. Flow Graph x -> Flow Graph x
withSchemaContext (Flow Graph RowType -> Flow Graph RowType)
-> Flow Graph RowType -> Flow Graph RowType
forall a b. (a -> b) -> a -> b
$ Bool -> Name -> Flow Graph RowType
requireUnionType Bool
False Name
dn
            let fieldMap :: Map Name FieldType
fieldMap = [(Name, FieldType)] -> Map Name FieldType
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, FieldType)] -> Map Name FieldType)
-> [(Name, FieldType)] -> Map Name FieldType
forall a b. (a -> b) -> a -> b
$ (\FieldType
f -> (FieldType -> Name
fieldTypeName FieldType
f, FieldType
f)) (FieldType -> (Name, FieldType))
-> [FieldType] -> [(Name, FieldType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RowType -> [FieldType]
rowTypeFields RowType
rt
            [Alternative]
ecases <- (Field -> Flow Graph Alternative)
-> [Field] -> Flow Graph [Alternative]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM (Map Name FieldType -> Field -> Flow Graph Alternative
toAlt Map Name FieldType
fieldMap) [Field]
fields
            [Alternative]
dcases <- case Maybe Term
def of
              Maybe Term
Nothing -> [Alternative] -> Flow Graph [Alternative]
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
              Just Term
d -> do
                CaseRhs
cs <- Expression -> CaseRhs
H.CaseRhs (Expression -> CaseRhs)
-> Flow Graph Expression -> Flow Graph CaseRhs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespaces -> Term -> Flow Graph Expression
encodeTerm Namespaces
namespaces Term
d
                let lhs :: Pattern
lhs = Name -> Pattern
H.PatternName (Name -> Pattern) -> Name -> Pattern
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
rawName FilePath
ignoredVariable
                [Alternative] -> Flow Graph [Alternative]
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return [Pattern -> CaseRhs -> Maybe LocalBindings -> Alternative
H.Alternative Pattern
lhs CaseRhs
cs Maybe LocalBindings
forall a. Maybe a
Nothing]
            Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Expression_Case -> Expression
H.ExpressionCase (Expression_Case -> Expression) -> Expression_Case -> Expression
forall a b. (a -> b) -> a -> b
$ Expression -> [Alternative] -> Expression_Case
H.Expression_Case (FilePath -> Expression
hsvar FilePath
"x") ([Alternative] -> Expression_Case)
-> [Alternative] -> Expression_Case
forall a b. (a -> b) -> a -> b
$ [Alternative]
ecases [Alternative] -> [Alternative] -> [Alternative]
forall a. [a] -> [a] -> [a]
++ [Alternative]
dcases
          toAlt :: Map Name FieldType -> Field -> Flow Graph Alternative
toAlt Map Name FieldType
fieldMap (Field Name
fn Term
fun') = do
            FilePath
v0 <- (\Int
i -> FilePath
"v" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i) (Int -> FilePath) -> Flow Graph Int -> Flow Graph FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Flow Graph Int
forall s. FilePath -> Flow s Int
nextCount FilePath
"haskellVar"
            let raw :: Term
raw = Term -> Term -> Term
apply Term
fun' (FilePath -> Term
var FilePath
v0)
            let rhsTerm :: Term
rhsTerm = Term -> Term
simplifyTerm Term
raw
            let v1 :: FilePath
v1 = if Name -> Term -> Bool
isFreeIn (FilePath -> Name
Name FilePath
v0) Term
rhsTerm then FilePath
ignoredVariable else FilePath
v0
            let hname :: Name
hname = Namespaces -> Name -> Name -> Name
unionFieldReference Namespaces
namespaces Name
dn Name
fn
            [Pattern]
args <- case Name -> Map Name FieldType -> Maybe FieldType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fn Map Name FieldType
fieldMap of
              Just (FieldType Name
_ Type
ft) -> case Type -> Type
stripType Type
ft of
                TypeRecord (RowType Name
_ Maybe Name
Nothing []) -> [Pattern] -> Flow Graph [Pattern]
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                Type
_ -> [Pattern] -> Flow Graph [Pattern]
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Name -> Pattern
H.PatternName (Name -> Pattern) -> Name -> Pattern
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
rawName FilePath
v1]
              Maybe FieldType
Nothing -> FilePath -> Flow Graph [Pattern]
forall a. FilePath -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Flow Graph [Pattern])
-> FilePath -> Flow Graph [Pattern]
forall a b. (a -> b) -> a -> b
$ FilePath
"field " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
forall a. Show a => a -> FilePath
show Name
fn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not found in " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
forall a. Show a => a -> FilePath
show Name
dn
            let lhs :: Pattern
lhs = Name -> [Pattern] -> Pattern
applicationPattern Name
hname [Pattern]
args
            CaseRhs
rhs <- Expression -> CaseRhs
H.CaseRhs (Expression -> CaseRhs)
-> Flow Graph Expression -> Flow Graph CaseRhs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespaces -> Term -> Flow Graph Expression
encodeTerm Namespaces
namespaces Term
rhsTerm
            Alternative -> Flow Graph Alternative
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Alternative -> Flow Graph Alternative)
-> Alternative -> Flow Graph Alternative
forall a b. (a -> b) -> a -> b
$ Pattern -> CaseRhs -> Maybe LocalBindings -> Alternative
H.Alternative Pattern
lhs CaseRhs
rhs Maybe LocalBindings
forall a. Maybe a
Nothing
    FunctionLambda (Lambda (Name FilePath
v) Term
body) -> FilePath -> Expression -> Expression
hslambda FilePath
v (Expression -> Expression)
-> Flow Graph Expression -> Flow Graph Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespaces -> Term -> Flow Graph Expression
encodeTerm Namespaces
namespaces Term
body
    FunctionPrimitive Name
name -> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Name -> Expression
H.ExpressionVariable (Name -> Expression) -> Name -> Expression
forall a b. (a -> b) -> a -> b
$ Name -> Name
hsPrimitiveReference Name
name

encodeLiteral :: Literal -> Flow Graph H.Expression
encodeLiteral :: Literal -> Flow Graph Expression
encodeLiteral Literal
av = case Literal
av of
    LiteralBoolean Bool
b -> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ FilePath -> Expression
hsvar (FilePath -> Expression) -> FilePath -> Expression
forall a b. (a -> b) -> a -> b
$ if Bool
b then FilePath
"True" else FilePath
"False"
    LiteralFloat FloatValue
fv -> case FloatValue
fv of
      FloatValueFloat32 Float
f -> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Literal -> Expression
hslit (Literal -> Expression) -> Literal -> Expression
forall a b. (a -> b) -> a -> b
$ Float -> Literal
H.LiteralFloat Float
f
      FloatValueFloat64 Double
f -> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Literal -> Expression
hslit (Literal -> Expression) -> Literal -> Expression
forall a b. (a -> b) -> a -> b
$ Double -> Literal
H.LiteralDouble Double
f
      FloatValue
_ -> FilePath -> FilePath -> Flow Graph Expression
forall s x. FilePath -> FilePath -> Flow s x
unexpected FilePath
"floating-point number" (FilePath -> Flow Graph Expression)
-> FilePath -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ FloatValue -> FilePath
forall a. Show a => a -> FilePath
show FloatValue
fv
    LiteralInteger IntegerValue
iv -> case IntegerValue
iv of
      IntegerValueBigint Integer
i -> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Literal -> Expression
hslit (Literal -> Expression) -> Literal -> Expression
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
H.LiteralInteger Integer
i
      IntegerValueInt32 Int
i -> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Literal -> Expression
hslit (Literal -> Expression) -> Literal -> Expression
forall a b. (a -> b) -> a -> b
$ Int -> Literal
H.LiteralInt Int
i
      IntegerValue
_ -> FilePath -> FilePath -> Flow Graph Expression
forall s x. FilePath -> FilePath -> Flow s x
unexpected FilePath
"integer" (FilePath -> Flow Graph Expression)
-> FilePath -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ IntegerValue -> FilePath
forall a. Show a => a -> FilePath
show IntegerValue
iv
    LiteralString FilePath
s -> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Literal -> Expression
hslit (Literal -> Expression) -> Literal -> Expression
forall a b. (a -> b) -> a -> b
$ FilePath -> Literal
H.LiteralString FilePath
s
    Literal
_ -> FilePath -> FilePath -> Flow Graph Expression
forall s x. FilePath -> FilePath -> Flow s x
unexpected FilePath
"literal value" (FilePath -> Flow Graph Expression)
-> FilePath -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Literal -> FilePath
forall a. Show a => a -> FilePath
show Literal
av

encodeTerm :: Namespaces -> Term -> Flow Graph H.Expression
encodeTerm :: Namespaces -> Term -> Flow Graph Expression
encodeTerm Namespaces
namespaces Term
term = do
   case Term -> Term
fullyStripTerm Term
term of
    TermApplication (Application Term
fun Term
arg) -> Expression -> Expression -> Expression
hsapp (Expression -> Expression -> Expression)
-> Flow Graph Expression -> Flow Graph (Expression -> Expression)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow Graph Expression
encode Term
fun Flow Graph (Expression -> Expression)
-> Flow Graph Expression -> Flow Graph Expression
forall a b. Flow Graph (a -> b) -> Flow Graph a -> Flow Graph b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> Flow Graph Expression
encode Term
arg
    TermFunction Function
f -> Namespaces -> Function -> Flow Graph Expression
encodeFunction Namespaces
namespaces Function
f
    TermLet (Let [LetBinding]
bindings Term
env) -> do
        [LocalBinding]
hbindings <- (LetBinding -> Flow Graph LocalBinding)
-> [LetBinding] -> Flow Graph [LocalBinding]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM LetBinding -> Flow Graph LocalBinding
encodeBinding [LetBinding]
bindings
        Expression
hinner <- Term -> Flow Graph Expression
encode Term
env
        Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Expression_Let -> Expression
H.ExpressionLet (Expression_Let -> Expression) -> Expression_Let -> Expression
forall a b. (a -> b) -> a -> b
$ [LocalBinding] -> Expression -> Expression_Let
H.Expression_Let [LocalBinding]
hbindings Expression
hinner
      where
        encodeBinding :: LetBinding -> Flow Graph LocalBinding
encodeBinding (LetBinding Name
name Term
term Maybe TypeScheme
_) = do
          let hname :: Name
hname = FilePath -> Name
simpleName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
unName Name
name
          Expression
hexpr <- Term -> Flow Graph Expression
encode Term
term
          LocalBinding -> Flow Graph LocalBinding
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalBinding -> Flow Graph LocalBinding)
-> LocalBinding -> Flow Graph LocalBinding
forall a b. (a -> b) -> a -> b
$ ValueBinding -> LocalBinding
H.LocalBindingValue (ValueBinding -> LocalBinding) -> ValueBinding -> LocalBinding
forall a b. (a -> b) -> a -> b
$ Name -> Expression -> Maybe LocalBindings -> ValueBinding
simpleValueBinding Name
hname Expression
hexpr Maybe LocalBindings
forall a. Maybe a
Nothing
    TermList [Term]
els -> [Expression] -> Expression
H.ExpressionList ([Expression] -> Expression)
-> Flow Graph [Expression] -> Flow Graph Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term -> Flow Graph Expression)
-> [Term] -> Flow Graph [Expression]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM Term -> Flow Graph Expression
encode [Term]
els
    TermLiteral Literal
v -> Literal -> Flow Graph Expression
encodeLiteral Literal
v
    TermWrap (WrappedTerm Name
tname Term
term') -> if Bool
newtypesNotTypedefs
      then Expression -> Expression -> Expression
hsapp (Expression -> Expression -> Expression)
-> Flow Graph Expression -> Flow Graph (Expression -> Expression)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Expression
H.ExpressionVariable (Name -> Expression) -> Name -> Expression
forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> Name
elementReference Namespaces
namespaces Name
tname) Flow Graph (Expression -> Expression)
-> Flow Graph Expression -> Flow Graph Expression
forall a b. Flow Graph (a -> b) -> Flow Graph a -> Flow Graph b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> Flow Graph Expression
encode Term
term'
      else Term -> Flow Graph Expression
encode Term
term'
    TermOptional Maybe Term
m -> case Maybe Term
m of
      Maybe Term
Nothing -> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ FilePath -> Expression
hsvar FilePath
"Nothing"
      Just Term
t -> Expression -> Expression -> Expression
hsapp (FilePath -> Expression
hsvar FilePath
"Just") (Expression -> Expression)
-> Flow Graph Expression -> Flow Graph Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow Graph Expression
encode Term
t
    TermProduct [Term]
terms -> [Expression] -> Expression
H.ExpressionTuple ([Expression] -> Expression)
-> Flow Graph [Expression] -> Flow Graph Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Term -> Flow Graph Expression)
-> [Term] -> Flow Graph [Expression]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM Term -> Flow Graph Expression
encode [Term]
terms)
    TermRecord (Record Name
sname [Field]
fields) -> do
      if [Field] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Field]
fields -- TODO: too permissive; not all empty record types are the unit type
        then Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ [Expression] -> Expression
H.ExpressionTuple []
        else do
            let typeName :: Name
typeName = Namespaces -> Name -> Name
elementReference Namespaces
namespaces Name
sname
            [FieldUpdate]
updates <- (Field -> Flow Graph FieldUpdate)
-> [Field] -> Flow Graph [FieldUpdate]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM Field -> Flow Graph FieldUpdate
toFieldUpdate [Field]
fields
            Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Expression_ConstructRecord -> Expression
H.ExpressionConstructRecord (Expression_ConstructRecord -> Expression)
-> Expression_ConstructRecord -> Expression
forall a b. (a -> b) -> a -> b
$ Name -> [FieldUpdate] -> Expression_ConstructRecord
H.Expression_ConstructRecord Name
typeName [FieldUpdate]
updates
          where
            toFieldUpdate :: Field -> Flow Graph FieldUpdate
toFieldUpdate (Field Name
fn Term
ft) = Name -> Expression -> FieldUpdate
H.FieldUpdate (Namespaces -> Name -> Name -> Name
recordFieldReference Namespaces
namespaces Name
sname Name
fn) (Expression -> FieldUpdate)
-> Flow Graph Expression -> Flow Graph FieldUpdate
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow Graph Expression
encode Term
ft
    TermUnion (Injection Name
sname (Field Name
fn Term
ft)) -> do
      let lhs :: Expression
lhs = Name -> Expression
H.ExpressionVariable (Name -> Expression) -> Name -> Expression
forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> Name -> Name
unionFieldReference Namespaces
namespaces Name
sname Name
fn
      case Term -> Term
fullyStripTerm Term
ft of
        TermRecord (Record Name
_ []) -> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Expression
lhs
        Term
_ -> Expression -> Expression -> Expression
hsapp Expression
lhs (Expression -> Expression)
-> Flow Graph Expression -> Flow Graph Expression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> Flow Graph Expression
encode Term
ft
    TermVariable Name
name -> Expression -> Flow Graph Expression
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Expression -> Flow Graph Expression)
-> Expression -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ Name -> Expression
H.ExpressionVariable (Name -> Expression) -> Name -> Expression
forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> Name
elementReference Namespaces
namespaces Name
name --pure $ hsvar v
    Term
t -> FilePath -> Flow Graph Expression
forall a. FilePath -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Flow Graph Expression)
-> FilePath -> Flow Graph Expression
forall a b. (a -> b) -> a -> b
$ FilePath
"unexpected term: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Term -> FilePath
forall a. Show a => a -> FilePath
show Term
t
  where
    encode :: Term -> Flow Graph Expression
encode = Namespaces -> Term -> Flow Graph Expression
encodeTerm Namespaces
namespaces

encodeType :: Namespaces -> Type -> Flow Graph H.Type
encodeType :: Namespaces -> Type -> Flow Graph Type
encodeType Namespaces
namespaces Type
typ = FilePath -> Flow Graph Type -> Flow Graph Type
forall s a. FilePath -> Flow s a -> Flow s a
withTrace FilePath
"encode type" (Flow Graph Type -> Flow Graph Type)
-> Flow Graph Type -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ case Type -> Type
stripType Type
typ of
    TypeApplication (ApplicationType Type
lhs Type
rhs) -> [Type] -> Type
toTypeApplication ([Type] -> Type) -> Flow Graph [Type] -> Flow Graph Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Flow Graph Type] -> Flow Graph [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
CM.sequence [Type -> Flow Graph Type
encode Type
lhs, Type -> Flow Graph Type
encode Type
rhs]
    TypeFunction (FunctionType Type
dom Type
cod) -> Type_Function -> Type
H.TypeFunction (Type_Function -> Type)
-> Flow Graph Type_Function -> Flow Graph Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Type -> Type_Function
H.Type_Function (Type -> Type -> Type_Function)
-> Flow Graph Type -> Flow Graph (Type -> Type_Function)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Flow Graph Type
encode Type
dom Flow Graph (Type -> Type_Function)
-> Flow Graph Type -> Flow Graph Type_Function
forall a b. Flow Graph (a -> b) -> Flow Graph a -> Flow Graph b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Flow Graph Type
encode Type
cod)
    TypeLambda (LambdaType (Name FilePath
v) Type
body) -> [Type] -> Type
toTypeApplication ([Type] -> Type) -> Flow Graph [Type] -> Flow Graph Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Flow Graph Type] -> Flow Graph [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
CM.sequence [
      Type -> Flow Graph Type
encode Type
body,
      Type -> Flow Graph Type
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Flow Graph Type) -> Type -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
H.TypeVariable (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
simpleName FilePath
v]
    TypeList Type
lt -> Type -> Type
H.TypeList (Type -> Type) -> Flow Graph Type -> Flow Graph Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Flow Graph Type
encode Type
lt
    TypeLiteral LiteralType
lt -> Name -> Type
H.TypeVariable (Name -> Type) -> (FilePath -> Name) -> FilePath -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Name
rawName (FilePath -> Type) -> Flow Graph FilePath -> Flow Graph Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case LiteralType
lt of
      LiteralType
LiteralTypeBoolean -> FilePath -> Flow Graph FilePath
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"Bool"
      LiteralTypeFloat FloatType
ft -> case FloatType
ft of
        FloatType
FloatTypeFloat32 -> FilePath -> Flow Graph FilePath
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"Float"
        FloatType
FloatTypeFloat64 -> FilePath -> Flow Graph FilePath
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"Double"
        FloatType
FloatTypeBigfloat -> FilePath -> Flow Graph FilePath
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"Double" -- TODO: type adapter should prevent this
--        _ -> fail $ "unexpected floating-point type: " ++ show ft
      LiteralTypeInteger IntegerType
it -> case IntegerType
it of
        IntegerType
IntegerTypeBigint -> FilePath -> Flow Graph FilePath
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"Integer"
        IntegerType
IntegerTypeInt8 -> FilePath -> Flow Graph FilePath
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"Int8"
        IntegerType
IntegerTypeInt16 -> FilePath -> Flow Graph FilePath
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"Int16"
        IntegerType
IntegerTypeInt32 -> FilePath -> Flow Graph FilePath
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"Int"
        IntegerType
IntegerTypeInt64 -> FilePath -> Flow Graph FilePath
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"Int64"
        IntegerType
_ -> FilePath -> Flow Graph FilePath
forall a. FilePath -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Flow Graph FilePath)
-> FilePath -> Flow Graph FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"unexpected integer type: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ IntegerType -> FilePath
forall a. Show a => a -> FilePath
show IntegerType
it
      LiteralType
LiteralTypeString -> FilePath -> Flow Graph FilePath
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
"String"
      LiteralType
_ -> FilePath -> Flow Graph FilePath
forall a. FilePath -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Flow Graph FilePath)
-> FilePath -> Flow Graph FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"unexpected literal type: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ LiteralType -> FilePath
forall a. Show a => a -> FilePath
show LiteralType
lt
    TypeMap (MapType Type
kt Type
vt) -> [Type] -> Type
toTypeApplication ([Type] -> Type) -> Flow Graph [Type] -> Flow Graph Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Flow Graph Type] -> Flow Graph [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
CM.sequence [
      Type -> Flow Graph Type
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Flow Graph Type) -> Type -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
H.TypeVariable (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
rawName FilePath
"Map",
      Type -> Flow Graph Type
encode Type
kt,
      Type -> Flow Graph Type
encode Type
vt]
    TypeOptional Type
ot -> [Type] -> Type
toTypeApplication ([Type] -> Type) -> Flow Graph [Type] -> Flow Graph Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Flow Graph Type] -> Flow Graph [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
CM.sequence [
      Type -> Flow Graph Type
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Flow Graph Type) -> Type -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
H.TypeVariable (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
rawName FilePath
"Maybe",
      Type -> Flow Graph Type
encode Type
ot]
    TypeProduct [Type]
types -> [Type] -> Type
H.TypeTuple ([Type] -> Type) -> Flow Graph [Type] -> Flow Graph Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type -> Flow Graph Type) -> [Type] -> Flow Graph [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM Type -> Flow Graph Type
encode [Type]
types)
    TypeRecord RowType
rt -> case RowType -> [FieldType]
rowTypeFields RowType
rt of
      [] -> Type -> Flow Graph Type
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Flow Graph Type) -> Type -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
H.TypeTuple []  -- TODO: too permissive; not all empty record types are the unit type
      [FieldType]
_ -> Name -> Flow Graph Type
forall {f :: * -> *}. Applicative f => Name -> f Type
ref (Name -> Flow Graph Type) -> Name -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ RowType -> Name
rowTypeTypeName RowType
rt
    TypeSet Type
st -> [Type] -> Type
toTypeApplication ([Type] -> Type) -> Flow Graph [Type] -> Flow Graph Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Flow Graph Type] -> Flow Graph [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
CM.sequence [
      Type -> Flow Graph Type
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Flow Graph Type) -> Type -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
H.TypeVariable (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
rawName FilePath
"Set",
      Type -> Flow Graph Type
encode Type
st]
    TypeUnion RowType
rt -> Name -> Flow Graph Type
forall {f :: * -> *}. Applicative f => Name -> f Type
ref (Name -> Flow Graph Type) -> Name -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ RowType -> Name
rowTypeTypeName RowType
rt
    TypeVariable Name
v -> Name -> Flow Graph Type
forall {f :: * -> *}. Applicative f => Name -> f Type
ref Name
v
    TypeWrap (WrappedType Name
name Type
_) -> Name -> Flow Graph Type
forall {f :: * -> *}. Applicative f => Name -> f Type
ref Name
name
    Type
_ -> FilePath -> Flow Graph Type
forall a. FilePath -> Flow Graph a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Flow Graph Type) -> FilePath -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ FilePath
"unexpected type: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Type -> FilePath
forall a. Show a => a -> FilePath
show Type
typ
  where
    encode :: Type -> Flow Graph Type
encode = Namespaces -> Type -> Flow Graph Type
encodeType Namespaces
namespaces
    ref :: Name -> f Type
ref Name
name = Type -> f Type
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> f Type) -> Type -> f Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
H.TypeVariable (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Namespaces -> Name -> Name
elementReference Namespaces
namespaces Name
name

encodeTypeWithClassAssertions :: Namespaces -> M.Map Name (S.Set TypeClass) -> Type -> Flow Graph H.Type
encodeTypeWithClassAssertions :: Namespaces -> Map Name (Set TypeClass) -> Type -> Flow Graph Type
encodeTypeWithClassAssertions Namespaces
namespaces Map Name (Set TypeClass)
classes Type
typ = FilePath -> Flow Graph Type -> Flow Graph Type
forall s a. FilePath -> Flow s a -> Flow s a
withTrace FilePath
"encode with assertions" (Flow Graph Type -> Flow Graph Type)
-> Flow Graph Type -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ do
  Type
htyp <- Namespaces -> Type -> Flow Graph Type
adaptTypeToHaskellAndEncode Namespaces
namespaces Type
typ
  if [(Name, TypeClass)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [(Name, TypeClass)]
assertPairs
    then Type -> Flow Graph Type
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
htyp
    else do
      let encoded :: [Assertion]
encoded = (Name, TypeClass) -> Assertion
encodeAssertion ((Name, TypeClass) -> Assertion)
-> [(Name, TypeClass)] -> [Assertion]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, TypeClass)]
assertPairs
      let hassert :: Assertion
hassert = if [Assertion] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length [Assertion]
encoded Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then [Assertion] -> Assertion
forall a. HasCallStack => [a] -> a
L.head [Assertion]
encoded else [Assertion] -> Assertion
H.AssertionTuple [Assertion]
encoded
      Type -> Flow Graph Type
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Flow Graph Type) -> Type -> Flow Graph Type
forall a b. (a -> b) -> a -> b
$ Type_Context -> Type
H.TypeCtx (Type_Context -> Type) -> Type_Context -> Type
forall a b. (a -> b) -> a -> b
$ Assertion -> Type -> Type_Context
H.Type_Context Assertion
hassert Type
htyp
  where
    encodeAssertion :: (Name, TypeClass) -> Assertion
encodeAssertion (Name
name, TypeClass
cls) = Assertion_Class -> Assertion
H.AssertionClass (Assertion_Class -> Assertion) -> Assertion_Class -> Assertion
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Assertion_Class
H.Assertion_Class Name
hname [Type
htype]
      where
        hname :: Name
hname = FilePath -> Name
rawName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ case TypeClass
cls of
          TypeClass
TypeClassEquality -> FilePath
"Eq"
          TypeClass
TypeClassOrdering -> FilePath
"Ord"
        htype :: Type
htype = Name -> Type
H.TypeVariable (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
rawName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
unName Name
name -- TODO: sanitization

    assertPairs :: [(Name, TypeClass)]
assertPairs = [[(Name, TypeClass)]] -> [(Name, TypeClass)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
L.concat ((Name, Set TypeClass) -> [(Name, TypeClass)]
forall {a} {a}. (a, Set a) -> [(a, a)]
toPairs ((Name, Set TypeClass) -> [(Name, TypeClass)])
-> [(Name, Set TypeClass)] -> [[(Name, TypeClass)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name (Set TypeClass) -> [(Name, Set TypeClass)]
forall k a. Map k a -> [(k, a)]
M.toList Map Name (Set TypeClass)
classes)
      where
        toPairs :: (a, Set a) -> [(a, a)]
toPairs (a
name, Set a
cls) = a -> (a, a)
forall {b}. b -> (a, b)
toPair (a -> (a, a)) -> [a] -> [(a, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
cls
          where
            toPair :: b -> (a, b)
toPair b
c = (a
name, b
c)

moduleToHaskellModule :: Module -> Flow Graph H.Module
moduleToHaskellModule :: Module -> Flow Graph Module
moduleToHaskellModule Module
mod = do
    Namespaces
namespaces <- Module -> Flow Graph Namespaces
namespacesForModule Module
mod
    Language
-> (Term -> Flow Graph Expression)
-> (Module
    -> Map Type (Coder Graph Graph Term Expression)
    -> [(Element, TypedTerm)]
    -> Flow Graph Module)
-> Module
-> Flow Graph Module
forall e d.
Language
-> (Term -> Flow Graph e)
-> (Module
    -> Map Type (Coder Graph Graph Term e)
    -> [(Element, TypedTerm)]
    -> Flow Graph d)
-> Module
-> Flow Graph d
transformModule Language
haskellLanguage (Namespaces -> Term -> Flow Graph Expression
encodeTerm Namespaces
namespaces) (Namespaces
-> Module
-> Map Type (Coder Graph Graph Term Expression)
-> [(Element, TypedTerm)]
-> Flow Graph Module
constructModule Namespaces
namespaces) Module
mod

moduleToHaskell :: Module -> Flow Graph (M.Map FilePath String)
moduleToHaskell :: Module -> Flow Graph (Map FilePath FilePath)
moduleToHaskell Module
mod = do
  Module
hsmod <- Module -> Flow Graph Module
moduleToHaskellModule Module
mod
  let s :: FilePath
s = Expr -> FilePath
printExpr (Expr -> FilePath) -> Expr -> FilePath
forall a b. (a -> b) -> a -> b
$ Expr -> Expr
parenthesize (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ Module -> Expr
forall a. ToTree a => a -> Expr
toTree Module
hsmod
  Map FilePath FilePath -> Flow Graph (Map FilePath FilePath)
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map FilePath FilePath -> Flow Graph (Map FilePath FilePath))
-> Map FilePath FilePath -> Flow Graph (Map FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ [(FilePath, FilePath)] -> Map FilePath FilePath
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Bool -> FileExtension -> Namespace -> FilePath
namespaceToFilePath Bool
True (FilePath -> FileExtension
FileExtension FilePath
"hs") (Namespace -> FilePath) -> Namespace -> FilePath
forall a b. (a -> b) -> a -> b
$ Module -> Namespace
moduleNamespace Module
mod, FilePath
s)]

toDataDeclaration :: M.Map Type (Coder Graph Graph Term H.Expression) -> Namespaces
  -> (Element, TypedTerm) -> Flow Graph H.DeclarationWithComments
toDataDeclaration :: Map Type (Coder Graph Graph Term Expression)
-> Namespaces
-> (Element, TypedTerm)
-> Flow Graph DeclarationWithComments
toDataDeclaration Map Type (Coder Graph Graph Term Expression)
coders Namespaces
namespaces (Element
el, TypedTerm Term
term Type
typ) = do
  Maybe FilePath
comments <- Term -> Flow Graph (Maybe FilePath)
getTermDescription Term
term
  Maybe FilePath
-> Name
-> Term
-> Coder Graph Graph Term Expression
-> Maybe LocalBindings
-> Flow Graph DeclarationWithComments
forall {s2}.
Maybe FilePath
-> Name
-> Term
-> Coder Graph s2 Term Expression
-> Maybe LocalBindings
-> Flow Graph DeclarationWithComments
toDecl Maybe FilePath
comments Name
hname Term
term Coder Graph Graph Term Expression
coder Maybe LocalBindings
forall a. Maybe a
Nothing
  where
    coder :: Coder Graph Graph Term Expression
coder = Maybe (Coder Graph Graph Term Expression)
-> Coder Graph Graph Term Expression
forall a. HasCallStack => Maybe a -> a
Y.fromJust (Maybe (Coder Graph Graph Term Expression)
 -> Coder Graph Graph Term Expression)
-> Maybe (Coder Graph Graph Term Expression)
-> Coder Graph Graph Term Expression
forall a b. (a -> b) -> a -> b
$ Type
-> Map Type (Coder Graph Graph Term Expression)
-> Maybe (Coder Graph Graph Term Expression)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Type
typ Map Type (Coder Graph Graph Term Expression)
coders
    hname :: Name
hname = FilePath -> Name
simpleName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
localNameOfEager (Name -> FilePath) -> Name -> FilePath
forall a b. (a -> b) -> a -> b
$ Element -> Name
elementName Element
el

    rewriteValueBinding :: ValueBinding -> ValueBinding
rewriteValueBinding ValueBinding
vb = case ValueBinding
vb of
      H.ValueBindingSimple (H.ValueBinding_Simple (H.PatternApplication (H.Pattern_Application Name
name [Pattern]
args)) RightHandSide
rhs Maybe LocalBindings
bindings) -> case RightHandSide
rhs of
        H.RightHandSide (H.ExpressionLambda (H.Expression_Lambda [Pattern]
vars Expression
body)) -> ValueBinding -> ValueBinding
rewriteValueBinding (ValueBinding -> ValueBinding) -> ValueBinding -> ValueBinding
forall a b. (a -> b) -> a -> b
$
          ValueBinding_Simple -> ValueBinding
H.ValueBindingSimple (ValueBinding_Simple -> ValueBinding)
-> ValueBinding_Simple -> ValueBinding
forall a b. (a -> b) -> a -> b
$ Pattern
-> RightHandSide -> Maybe LocalBindings -> ValueBinding_Simple
H.ValueBinding_Simple
            (Name -> [Pattern] -> Pattern
applicationPattern Name
name ([Pattern]
args [Pattern] -> [Pattern] -> [Pattern]
forall a. [a] -> [a] -> [a]
++ [Pattern]
vars)) (Expression -> RightHandSide
H.RightHandSide Expression
body) Maybe LocalBindings
bindings
        RightHandSide
_ -> ValueBinding
vb

    toDecl :: Maybe FilePath
-> Name
-> Term
-> Coder Graph s2 Term Expression
-> Maybe LocalBindings
-> Flow Graph DeclarationWithComments
toDecl Maybe FilePath
comments Name
hname Term
term Coder Graph s2 Term Expression
coder Maybe LocalBindings
bindings = case Term -> Term
fullyStripTerm Term
term of
      TermLet (Let [LetBinding]
lbindings Term
env) -> do
          -- A "let" constant cannot be predicted in advance, so we infer its type and construct a coder on the fly
          -- This makes program code with "let" terms more expensive to transform than simple data.
          [Type]
ts <- ((Term -> Flow Graph Type) -> [Term] -> Flow Graph [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM Term -> Flow Graph Type
inferType (LetBinding -> Term
letBindingTerm (LetBinding -> Term) -> [LetBinding] -> [Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LetBinding]
lbindings))
          [Coder Graph Graph Term Expression]
coders <- (Type -> Flow Graph (Coder Graph Graph Term Expression))
-> [Type] -> Flow Graph [Coder Graph Graph Term Expression]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM (Language
-> (Term -> Flow Graph Expression)
-> Type
-> Flow Graph (Coder Graph Graph Term Expression)
forall c.
Language
-> (Term -> Flow Graph c)
-> Type
-> Flow Graph (Coder Graph Graph Term c)
constructCoder Language
haskellLanguage (Namespaces -> Term -> Flow Graph Expression
encodeTerm Namespaces
namespaces)) [Type]
ts
          let hnames :: [Name]
hnames = FilePath -> Name
simpleName (FilePath -> Name) -> [FilePath] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> FilePath
unName (Name -> FilePath)
-> (LetBinding -> Name) -> LetBinding -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LetBinding -> Name
letBindingName (LetBinding -> FilePath) -> [LetBinding] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LetBinding]
lbindings)
          [Expression]
hterms <- (Coder Graph Graph Term Expression
 -> Term -> Flow Graph Expression)
-> [Coder Graph Graph Term Expression]
-> [Term]
-> Flow Graph [Expression]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
CM.zipWithM Coder Graph Graph Term Expression -> Term -> Flow Graph Expression
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode [Coder Graph Graph Term Expression]
coders (LetBinding -> Term
letBindingTerm (LetBinding -> Term) -> [LetBinding] -> [Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LetBinding]
lbindings)

          let hbindings :: [LocalBinding]
hbindings = (Name -> Expression -> LocalBinding)
-> [Name] -> [Expression] -> [LocalBinding]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
L.zipWith Name -> Expression -> LocalBinding
toBinding [Name]
hnames [Expression]
hterms
          Maybe FilePath
-> Name
-> Term
-> Coder Graph s2 Term Expression
-> Maybe LocalBindings
-> Flow Graph DeclarationWithComments
toDecl Maybe FilePath
comments Name
hname Term
env Coder Graph s2 Term Expression
coder (LocalBindings -> Maybe LocalBindings
forall a. a -> Maybe a
Just (LocalBindings -> Maybe LocalBindings)
-> LocalBindings -> Maybe LocalBindings
forall a b. (a -> b) -> a -> b
$ [LocalBinding] -> LocalBindings
H.LocalBindings [LocalBinding]
hbindings)
        where
          toBinding :: Name -> Expression -> LocalBinding
toBinding Name
hname' Expression
hterm' = ValueBinding -> LocalBinding
H.LocalBindingValue (ValueBinding -> LocalBinding) -> ValueBinding -> LocalBinding
forall a b. (a -> b) -> a -> b
$ Name -> Expression -> Maybe LocalBindings -> ValueBinding
simpleValueBinding Name
hname' Expression
hterm' Maybe LocalBindings
forall a. Maybe a
Nothing
      Term
_ -> do
        Expression
hterm <- Coder Graph s2 Term Expression -> Term -> Flow Graph Expression
forall s1 s2 v1 v2. Coder s1 s2 v1 v2 -> v1 -> Flow s1 v2
coderEncode Coder Graph s2 Term Expression
coder Term
term
        let vb :: ValueBinding
vb = Name -> Expression -> Maybe LocalBindings -> ValueBinding
simpleValueBinding Name
hname Expression
hterm Maybe LocalBindings
bindings
        Map Name (Set TypeClass)
classes <- Type -> Flow Graph (Map Name (Set TypeClass))
getTypeClasses Type
typ
        Type
htype <- Namespaces -> Map Name (Set TypeClass) -> Type -> Flow Graph Type
encodeTypeWithClassAssertions Namespaces
namespaces Map Name (Set TypeClass)
classes Type
typ
        let decl :: Declaration
decl = TypedBinding -> Declaration
H.DeclarationTypedBinding (TypedBinding -> Declaration) -> TypedBinding -> Declaration
forall a b. (a -> b) -> a -> b
$ TypeSignature -> ValueBinding -> TypedBinding
H.TypedBinding (Name -> Type -> TypeSignature
H.TypeSignature Name
hname Type
htype) (ValueBinding -> ValueBinding
rewriteValueBinding ValueBinding
vb)
        DeclarationWithComments -> Flow Graph DeclarationWithComments
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (DeclarationWithComments -> Flow Graph DeclarationWithComments)
-> DeclarationWithComments -> Flow Graph DeclarationWithComments
forall a b. (a -> b) -> a -> b
$ Declaration -> Maybe FilePath -> DeclarationWithComments
H.DeclarationWithComments Declaration
decl Maybe FilePath
comments

toTypeDeclarations :: Namespaces -> Element -> Term -> Flow Graph [H.DeclarationWithComments]
toTypeDeclarations :: Namespaces
-> Element -> Term -> Flow Graph [DeclarationWithComments]
toTypeDeclarations Namespaces
namespaces Element
el Term
term = FilePath
-> Flow Graph [DeclarationWithComments]
-> Flow Graph [DeclarationWithComments]
forall s a. FilePath -> Flow s a -> Flow s a
withTrace (FilePath
"type element " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
unName (Element -> Name
elementName Element
el)) (Flow Graph [DeclarationWithComments]
 -> Flow Graph [DeclarationWithComments])
-> Flow Graph [DeclarationWithComments]
-> Flow Graph [DeclarationWithComments]
forall a b. (a -> b) -> a -> b
$ do
    Graph
g <- Flow Graph Graph
forall s. Flow s s
getState
    let lname :: FilePath
lname = Name -> FilePath
localNameOfEager (Name -> FilePath) -> Name -> FilePath
forall a b. (a -> b) -> a -> b
$ Element -> Name
elementName Element
el
    let hname :: Name
hname = FilePath -> Name
simpleName FilePath
lname
    Type
t <- Term -> Flow Graph Type
coreDecodeType Term
term

    Bool
isSer <- Element -> Flow Graph Bool
isSerializable Element
el
    let deriv :: Deriving
deriv = [Name] -> Deriving
H.Deriving ([Name] -> Deriving) -> [Name] -> Deriving
forall a b. (a -> b) -> a -> b
$ if Bool
isSer
                  then FilePath -> Name
rawName (FilePath -> Name) -> [FilePath] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath
"Eq", FilePath
"Ord", FilePath
"Read", FilePath
"Show"]
                  else []
    let ([Name]
vars, Type
t') = Graph -> Type -> ([Name], Type)
unpackLambdaType Graph
g Type
t
    let hd :: DeclarationHead
hd = Name -> [Name] -> DeclarationHead
declHead Name
hname ([Name] -> DeclarationHead) -> [Name] -> DeclarationHead
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
L.reverse [Name]
vars
    Declaration
decl <- case Type -> Type
stripType Type
t' of
      TypeRecord RowType
rt -> do
        ConstructorWithComments
cons <- FilePath -> [FieldType] -> Flow Graph ConstructorWithComments
recordCons FilePath
lname ([FieldType] -> Flow Graph ConstructorWithComments)
-> [FieldType] -> Flow Graph ConstructorWithComments
forall a b. (a -> b) -> a -> b
$ RowType -> [FieldType]
rowTypeFields RowType
rt
        Declaration -> Flow Graph Declaration
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Declaration -> Flow Graph Declaration)
-> Declaration -> Flow Graph Declaration
forall a b. (a -> b) -> a -> b
$ DataDeclaration -> Declaration
H.DeclarationData (DataDeclaration -> Declaration) -> DataDeclaration -> Declaration
forall a b. (a -> b) -> a -> b
$ DataDeclaration_Keyword
-> [Assertion]
-> DeclarationHead
-> [ConstructorWithComments]
-> [Deriving]
-> DataDeclaration
H.DataDeclaration DataDeclaration_Keyword
H.DataDeclaration_KeywordData [] DeclarationHead
hd [ConstructorWithComments
cons] [Deriving
deriv]
      TypeUnion RowType
rt -> do
        [ConstructorWithComments]
cons <- (FieldType -> Flow Graph ConstructorWithComments)
-> [FieldType] -> Flow Graph [ConstructorWithComments]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM (FilePath -> FieldType -> Flow Graph ConstructorWithComments
unionCons FilePath
lname) ([FieldType] -> Flow Graph [ConstructorWithComments])
-> [FieldType] -> Flow Graph [ConstructorWithComments]
forall a b. (a -> b) -> a -> b
$ RowType -> [FieldType]
rowTypeFields RowType
rt
        Declaration -> Flow Graph Declaration
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Declaration -> Flow Graph Declaration)
-> Declaration -> Flow Graph Declaration
forall a b. (a -> b) -> a -> b
$ DataDeclaration -> Declaration
H.DeclarationData (DataDeclaration -> Declaration) -> DataDeclaration -> Declaration
forall a b. (a -> b) -> a -> b
$ DataDeclaration_Keyword
-> [Assertion]
-> DeclarationHead
-> [ConstructorWithComments]
-> [Deriving]
-> DataDeclaration
H.DataDeclaration DataDeclaration_Keyword
H.DataDeclaration_KeywordData [] DeclarationHead
hd [ConstructorWithComments]
cons [Deriving
deriv]
      TypeWrap (WrappedType Name
tname Type
wt) -> do
        ConstructorWithComments
cons <- Element -> Type -> Flow Graph ConstructorWithComments
newtypeCons Element
el Type
wt
        Declaration -> Flow Graph Declaration
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Declaration -> Flow Graph Declaration)
-> Declaration -> Flow Graph Declaration
forall a b. (a -> b) -> a -> b
$ DataDeclaration -> Declaration
H.DeclarationData (DataDeclaration -> Declaration) -> DataDeclaration -> Declaration
forall a b. (a -> b) -> a -> b
$ DataDeclaration_Keyword
-> [Assertion]
-> DeclarationHead
-> [ConstructorWithComments]
-> [Deriving]
-> DataDeclaration
H.DataDeclaration DataDeclaration_Keyword
H.DataDeclaration_KeywordNewtype [] DeclarationHead
hd [ConstructorWithComments
cons] [Deriving
deriv]
      Type
_ -> if Bool
newtypesNotTypedefs
        then do
          ConstructorWithComments
cons <- Element -> Type -> Flow Graph ConstructorWithComments
newtypeCons Element
el Type
t'
          Declaration -> Flow Graph Declaration
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Declaration -> Flow Graph Declaration)
-> Declaration -> Flow Graph Declaration
forall a b. (a -> b) -> a -> b
$ DataDeclaration -> Declaration
H.DeclarationData (DataDeclaration -> Declaration) -> DataDeclaration -> Declaration
forall a b. (a -> b) -> a -> b
$ DataDeclaration_Keyword
-> [Assertion]
-> DeclarationHead
-> [ConstructorWithComments]
-> [Deriving]
-> DataDeclaration
H.DataDeclaration DataDeclaration_Keyword
H.DataDeclaration_KeywordNewtype [] DeclarationHead
hd [ConstructorWithComments
cons] [Deriving
deriv]
        else do
          Type
htype <- Namespaces -> Type -> Flow Graph Type
adaptTypeToHaskellAndEncode Namespaces
namespaces Type
t
          Declaration -> Flow Graph Declaration
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (Declaration -> Flow Graph Declaration)
-> Declaration -> Flow Graph Declaration
forall a b. (a -> b) -> a -> b
$ TypeDeclaration -> Declaration
H.DeclarationType (DeclarationHead -> Type -> TypeDeclaration
H.TypeDeclaration DeclarationHead
hd Type
htype)
    Maybe FilePath
comments <- Term -> Flow Graph (Maybe FilePath)
getTermDescription Term
term
    [DeclarationWithComments] -> Flow Graph [DeclarationWithComments]
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DeclarationWithComments] -> Flow Graph [DeclarationWithComments])
-> [DeclarationWithComments]
-> Flow Graph [DeclarationWithComments]
forall a b. (a -> b) -> a -> b
$ [Declaration -> Maybe FilePath -> DeclarationWithComments
H.DeclarationWithComments Declaration
decl Maybe FilePath
comments] [DeclarationWithComments]
-> [DeclarationWithComments] -> [DeclarationWithComments]
forall a. [a] -> [a] -> [a]
++ Graph -> Namespaces -> Name -> Type -> [DeclarationWithComments]
constantDecls Graph
g Namespaces
namespaces (Element -> Name
elementName Element
el) Type
t
  where
    declHead :: Name -> [Name] -> DeclarationHead
declHead Name
name [Name]
vars = case [Name]
vars of
      [] -> Name -> DeclarationHead
H.DeclarationHeadSimple Name
name
      ((Name FilePath
h):[Name]
rest) -> DeclarationHead_Application -> DeclarationHead
H.DeclarationHeadApplication (DeclarationHead_Application -> DeclarationHead)
-> DeclarationHead_Application -> DeclarationHead
forall a b. (a -> b) -> a -> b
$
        DeclarationHead -> Variable -> DeclarationHead_Application
H.DeclarationHead_Application (Name -> [Name] -> DeclarationHead
declHead Name
name [Name]
rest) (Name -> Variable
H.Variable (Name -> Variable) -> Name -> Variable
forall a b. (a -> b) -> a -> b
$ FilePath -> Name
simpleName FilePath
h)

    newtypeCons :: Element -> Type -> Flow Graph ConstructorWithComments
newtypeCons Element
el Type
typ = do
        let hname :: Name
hname = FilePath -> Name
simpleName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
newtypeAccessorName (Name -> FilePath) -> Name -> FilePath
forall a b. (a -> b) -> a -> b
$ Element -> Name
elementName Element
el
        Type
htype <- Namespaces -> Type -> Flow Graph Type
adaptTypeToHaskellAndEncode Namespaces
namespaces Type
typ
        Maybe FilePath
comments <- Type -> Flow Graph (Maybe FilePath)
getTypeDescription Type
typ
        let hfield :: FieldWithComments
hfield = Field -> Maybe FilePath -> FieldWithComments
H.FieldWithComments (Name -> Type -> Field
H.Field Name
hname Type
htype) Maybe FilePath
comments
        ConstructorWithComments -> Flow Graph ConstructorWithComments
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorWithComments -> Flow Graph ConstructorWithComments)
-> ConstructorWithComments -> Flow Graph ConstructorWithComments
forall a b. (a -> b) -> a -> b
$ Constructor -> Maybe FilePath -> ConstructorWithComments
H.ConstructorWithComments
          (Constructor_Record -> Constructor
H.ConstructorRecord (Constructor_Record -> Constructor)
-> Constructor_Record -> Constructor
forall a b. (a -> b) -> a -> b
$ Name -> [FieldWithComments] -> Constructor_Record
H.Constructor_Record (FilePath -> Name
simpleName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
localNameOfEager (Name -> FilePath) -> Name -> FilePath
forall a b. (a -> b) -> a -> b
$ Element -> Name
elementName Element
el) [FieldWithComments
hfield]) Maybe FilePath
forall a. Maybe a
Nothing

    recordCons :: FilePath -> [FieldType] -> Flow Graph ConstructorWithComments
recordCons FilePath
lname [FieldType]
fields = do
        [FieldWithComments]
hFields <- (FieldType -> Flow Graph FieldWithComments)
-> [FieldType] -> Flow Graph [FieldWithComments]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
CM.mapM FieldType -> Flow Graph FieldWithComments
toField [FieldType]
fields
        ConstructorWithComments -> Flow Graph ConstructorWithComments
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorWithComments -> Flow Graph ConstructorWithComments)
-> ConstructorWithComments -> Flow Graph ConstructorWithComments
forall a b. (a -> b) -> a -> b
$ Constructor -> Maybe FilePath -> ConstructorWithComments
H.ConstructorWithComments (Constructor_Record -> Constructor
H.ConstructorRecord (Constructor_Record -> Constructor)
-> Constructor_Record -> Constructor
forall a b. (a -> b) -> a -> b
$ Name -> [FieldWithComments] -> Constructor_Record
H.Constructor_Record (FilePath -> Name
simpleName FilePath
lname) [FieldWithComments]
hFields) Maybe FilePath
forall a. Maybe a
Nothing
      where
        toField :: FieldType -> Flow Graph FieldWithComments
toField (FieldType (Name FilePath
fname) Type
ftype) = do
          let hname :: Name
hname = FilePath -> Name
simpleName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
decapitalize FilePath
lname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
capitalize FilePath
fname
          Type
htype <- Namespaces -> Type -> Flow Graph Type
adaptTypeToHaskellAndEncode Namespaces
namespaces Type
ftype
          Maybe FilePath
comments <- Type -> Flow Graph (Maybe FilePath)
getTypeDescription Type
ftype
          FieldWithComments -> Flow Graph FieldWithComments
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldWithComments -> Flow Graph FieldWithComments)
-> FieldWithComments -> Flow Graph FieldWithComments
forall a b. (a -> b) -> a -> b
$ Field -> Maybe FilePath -> FieldWithComments
H.FieldWithComments (Name -> Type -> Field
H.Field Name
hname Type
htype) Maybe FilePath
comments

    unionCons :: FilePath -> FieldType -> Flow Graph ConstructorWithComments
unionCons FilePath
lname (FieldType (Name FilePath
fname) Type
ftype) = do
      Maybe FilePath
comments <- Type -> Flow Graph (Maybe FilePath)
getTypeDescription Type
ftype
      let nm :: FilePath
nm = FilePath -> FilePath
capitalize FilePath
lname FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
capitalize FilePath
fname
      [Type]
typeList <- if Type -> Type
stripType Type
ftype Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
Types.unit
        then [Type] -> Flow Graph [Type]
forall a. a -> Flow Graph a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        else do
          Type
htype <- Namespaces -> Type -> Flow Graph Type
adaptTypeToHaskellAndEncode Namespaces
namespaces Type
ftype
          [Type] -> Flow Graph [Type]
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return [Type
htype]
      ConstructorWithComments -> Flow Graph ConstructorWithComments
forall a. a -> Flow Graph a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConstructorWithComments -> Flow Graph ConstructorWithComments)
-> ConstructorWithComments -> Flow Graph ConstructorWithComments
forall a b. (a -> b) -> a -> b
$ Constructor -> Maybe FilePath -> ConstructorWithComments
H.ConstructorWithComments (Constructor_Ordinary -> Constructor
H.ConstructorOrdinary (Constructor_Ordinary -> Constructor)
-> Constructor_Ordinary -> Constructor
forall a b. (a -> b) -> a -> b
$ Name -> [Type] -> Constructor_Ordinary
H.Constructor_Ordinary (FilePath -> Name
simpleName FilePath
nm) [Type]
typeList) Maybe FilePath
comments