{- |
    Module      :  $Header$
    Description :  Generation of typed FlatCurry program terms
    Copyright   :  (c) 2017        Finn Teegen
                       2018        Kai-Oliver Prott
    License     :  BSD-3-clause

    Maintainer  :  fte@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module contains the generation of a typed 'FlatCurry' program term
    for a given module in the intermediate language.
-}
{-# LANGUAGE CPP #-}
module Generators.GenTypedFlatCurry (genTypedFlatCurry) where

import Curry.FlatCurry.Annotated.Type
import Curry.FlatCurry.Annotated.Goodies
import Curry.FlatCurry.Typed.Type

-- transforms annotated FlatCurry code to typed FlatCurry code
genTypedFlatCurry :: AProg TypeExpr -> TProg
genTypedFlatCurry :: AProg TypeExpr -> TProg
genTypedFlatCurry = (String
 -> [String]
 -> [TypeDecl]
 -> [AFuncDecl TypeExpr]
 -> [OpDecl]
 -> TProg)
-> AProg TypeExpr -> TProg
forall a b.
(String
 -> [String] -> [TypeDecl] -> [AFuncDecl a] -> [OpDecl] -> b)
-> AProg a -> b
trAProg
  (\name :: String
name imps :: [String]
imps types :: [TypeDecl]
types funcs :: [AFuncDecl TypeExpr]
funcs ops :: [OpDecl]
ops ->
    String
-> [String] -> [TypeDecl] -> [TFuncDecl] -> [OpDecl] -> TProg
TProg String
name [String]
imps [TypeDecl]
types ((AFuncDecl TypeExpr -> TFuncDecl)
-> [AFuncDecl TypeExpr] -> [TFuncDecl]
forall a b. (a -> b) -> [a] -> [b]
map AFuncDecl TypeExpr -> TFuncDecl
genTypedFuncDecl [AFuncDecl TypeExpr]
funcs) [OpDecl]
ops)

genTypedFuncDecl :: AFuncDecl TypeExpr -> TFuncDecl
genTypedFuncDecl :: AFuncDecl TypeExpr -> TFuncDecl
genTypedFuncDecl = (QName
 -> Int -> Visibility -> TypeExpr -> ARule TypeExpr -> TFuncDecl)
-> AFuncDecl TypeExpr -> TFuncDecl
forall a b.
(QName -> Int -> Visibility -> TypeExpr -> ARule a -> b)
-> AFuncDecl a -> b
trAFunc
  (\name :: QName
name arity :: Int
arity vis :: Visibility
vis ty :: TypeExpr
ty rule :: ARule TypeExpr
rule -> QName -> Int -> Visibility -> TypeExpr -> TRule -> TFuncDecl
TFunc QName
name Int
arity Visibility
vis TypeExpr
ty (TRule -> TFuncDecl) -> TRule -> TFuncDecl
forall a b. (a -> b) -> a -> b
$ ARule TypeExpr -> TRule
genTypedRule ARule TypeExpr
rule)

genTypedRule :: ARule TypeExpr -> TRule
genTypedRule :: ARule TypeExpr -> TRule
genTypedRule = (TypeExpr -> [(Int, TypeExpr)] -> AExpr TypeExpr -> TRule)
-> (TypeExpr -> String -> TRule) -> ARule TypeExpr -> TRule
forall a b.
(a -> [(Int, a)] -> AExpr a -> b)
-> (a -> String -> b) -> ARule a -> b
trARule
  (\_ args :: [(Int, TypeExpr)]
args e :: AExpr TypeExpr
e -> [(Int, TypeExpr)] -> TExpr -> TRule
TRule [(Int, TypeExpr)]
args (TExpr -> TRule) -> TExpr -> TRule
forall a b. (a -> b) -> a -> b
$ AExpr TypeExpr -> TExpr
genTypedExpr AExpr TypeExpr
e)
  TypeExpr -> String -> TRule
TExternal

genTypedExpr :: AExpr TypeExpr -> TExpr
genTypedExpr :: AExpr TypeExpr -> TExpr
genTypedExpr = (TypeExpr -> Int -> TExpr)
-> (TypeExpr -> Literal -> TExpr)
-> (TypeExpr -> CombType -> (QName, TypeExpr) -> [TExpr] -> TExpr)
-> (TypeExpr -> [((Int, TypeExpr), TExpr)] -> TExpr -> TExpr)
-> (TypeExpr -> [(Int, TypeExpr)] -> TExpr -> TExpr)
-> (TypeExpr -> TExpr -> TExpr -> TExpr)
-> (TypeExpr -> CaseType -> TExpr -> [TBranchExpr] -> TExpr)
-> (APattern TypeExpr -> TExpr -> TBranchExpr)
-> (TypeExpr -> TExpr -> TypeExpr -> TExpr)
-> AExpr TypeExpr
-> TExpr
forall a b c.
(a -> Int -> b)
-> (a -> Literal -> b)
-> (a -> CombType -> (QName, a) -> [b] -> b)
-> (a -> [((Int, a), b)] -> b -> b)
-> (a -> [(Int, a)] -> b -> b)
-> (a -> b -> b -> b)
-> (a -> CaseType -> b -> [c] -> b)
-> (APattern a -> b -> c)
-> (a -> b -> TypeExpr -> b)
-> AExpr a
-> b
trAExpr
  TypeExpr -> Int -> TExpr
TVarE
  TypeExpr -> Literal -> TExpr
TLit
  (\ty :: TypeExpr
ty ct :: CombType
ct (name :: QName
name, _) args :: [TExpr]
args -> TypeExpr -> CombType -> QName -> [TExpr] -> TExpr
TComb TypeExpr
ty CombType
ct QName
name [TExpr]
args)
  (([((Int, TypeExpr), TExpr)] -> TExpr -> TExpr)
-> TypeExpr -> [((Int, TypeExpr), TExpr)] -> TExpr -> TExpr
forall a b. a -> b -> a
const [((Int, TypeExpr), TExpr)] -> TExpr -> TExpr
TLet)
  (([(Int, TypeExpr)] -> TExpr -> TExpr)
-> TypeExpr -> [(Int, TypeExpr)] -> TExpr -> TExpr
forall a b. a -> b -> a
const [(Int, TypeExpr)] -> TExpr -> TExpr
TFree)
  ((TExpr -> TExpr -> TExpr) -> TypeExpr -> TExpr -> TExpr -> TExpr
forall a b. a -> b -> a
const TExpr -> TExpr -> TExpr
TOr)
  ((CaseType -> TExpr -> [TBranchExpr] -> TExpr)
-> TypeExpr -> CaseType -> TExpr -> [TBranchExpr] -> TExpr
forall a b. a -> b -> a
const CaseType -> TExpr -> [TBranchExpr] -> TExpr
TCase)
  (TPattern -> TExpr -> TBranchExpr
TBranch (TPattern -> TExpr -> TBranchExpr)
-> (APattern TypeExpr -> TPattern)
-> APattern TypeExpr
-> TExpr
-> TBranchExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. APattern TypeExpr -> TPattern
genTypedPattern)
  ((TExpr -> TypeExpr -> TExpr)
-> TypeExpr -> TExpr -> TypeExpr -> TExpr
forall a b. a -> b -> a
const TExpr -> TypeExpr -> TExpr
TTyped)

genTypedPattern :: APattern TypeExpr -> TPattern
genTypedPattern :: APattern TypeExpr -> TPattern
genTypedPattern = (TypeExpr -> (QName, TypeExpr) -> [(Int, TypeExpr)] -> TPattern)
-> (TypeExpr -> Literal -> TPattern)
-> APattern TypeExpr
-> TPattern
forall a b.
(a -> (QName, a) -> [(Int, a)] -> b)
-> (a -> Literal -> b) -> APattern a -> b
trAPattern
  (\ty :: TypeExpr
ty (name :: QName
name, _) args :: [(Int, TypeExpr)]
args -> TypeExpr -> QName -> [(Int, TypeExpr)] -> TPattern
TPattern TypeExpr
ty QName
name [(Int, TypeExpr)]
args)
  TypeExpr -> Literal -> TPattern
TLPattern