{- |
    Module      :  $Header$
    Description :  Generation of FlatCurry program and interface terms
    Copyright   :  (c) 2017        Finn Teegen
    License     :  BSD-3-clause

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

    This module contains the generation of a 'FlatCurry' program term or
    a 'FlatCurry' interface out of an 'Annotated FlatCurry' module.
-}
module Generators.GenFlatCurry (genFlatCurry, genFlatInterface) where

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

-- transforms annotated FlatCurry code to FlatCurry code
genFlatCurry :: TProg -> Prog
genFlatCurry :: TProg -> Prog
genFlatCurry = (String
 -> [String] -> [TypeDecl] -> [TFuncDecl] -> [OpDecl] -> Prog)
-> TProg -> Prog
forall b.
(String -> [String] -> [TypeDecl] -> [TFuncDecl] -> [OpDecl] -> b)
-> TProg -> b
trTProg
  (\name :: String
name imps :: [String]
imps types :: [TypeDecl]
types funcs :: [TFuncDecl]
funcs ops :: [OpDecl]
ops ->
    String -> [String] -> [TypeDecl] -> [FuncDecl] -> [OpDecl] -> Prog
Prog String
name [String]
imps [TypeDecl]
types ((TFuncDecl -> FuncDecl) -> [TFuncDecl] -> [FuncDecl]
forall a b. (a -> b) -> [a] -> [b]
map TFuncDecl -> FuncDecl
genFlatFuncDecl [TFuncDecl]
funcs) [OpDecl]
ops)

genFlatFuncDecl :: TFuncDecl -> FuncDecl
genFlatFuncDecl :: TFuncDecl -> FuncDecl
genFlatFuncDecl = (QName -> Int -> Visibility -> TypeExpr -> TRule -> FuncDecl)
-> TFuncDecl -> FuncDecl
forall b.
(QName -> Int -> Visibility -> TypeExpr -> TRule -> b)
-> TFuncDecl -> b
trTFunc
  (\name :: QName
name arity :: Int
arity vis :: Visibility
vis ty :: TypeExpr
ty rule :: TRule
rule -> QName -> Int -> Visibility -> TypeExpr -> Rule -> FuncDecl
Func QName
name Int
arity Visibility
vis TypeExpr
ty (Rule -> FuncDecl) -> Rule -> FuncDecl
forall a b. (a -> b) -> a -> b
$ TRule -> Rule
genFlatRule TRule
rule)

genFlatRule :: TRule -> Rule
genFlatRule :: TRule -> Rule
genFlatRule = ([(Int, TypeExpr)] -> TExpr -> Rule)
-> (TypeExpr -> String -> Rule) -> TRule -> Rule
forall b.
([(Int, TypeExpr)] -> TExpr -> b)
-> (TypeExpr -> String -> b) -> TRule -> b
trTRule
  (\args :: [(Int, TypeExpr)]
args e :: TExpr
e -> [Int] -> Expr -> Rule
Rule (((Int, TypeExpr) -> Int) -> [(Int, TypeExpr)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, TypeExpr) -> Int
forall a b. (a, b) -> a
fst [(Int, TypeExpr)]
args) (Expr -> Rule) -> Expr -> Rule
forall a b. (a -> b) -> a -> b
$ TExpr -> Expr
genFlatExpr TExpr
e)
  ((String -> Rule) -> TypeExpr -> String -> Rule
forall a b. a -> b -> a
const String -> Rule
External)

genFlatExpr :: TExpr -> Expr
genFlatExpr :: TExpr -> Expr
genFlatExpr = (TypeExpr -> Int -> Expr)
-> (TypeExpr -> Literal -> Expr)
-> (TypeExpr -> CombType -> QName -> [Expr] -> Expr)
-> ([((Int, TypeExpr), Expr)] -> Expr -> Expr)
-> ([(Int, TypeExpr)] -> Expr -> Expr)
-> (Expr -> Expr -> Expr)
-> (CaseType -> Expr -> [BranchExpr] -> Expr)
-> (TPattern -> Expr -> BranchExpr)
-> (Expr -> TypeExpr -> Expr)
-> TExpr
-> Expr
forall b c.
(TypeExpr -> Int -> b)
-> (TypeExpr -> Literal -> b)
-> (TypeExpr -> CombType -> QName -> [b] -> b)
-> ([((Int, TypeExpr), b)] -> b -> b)
-> ([(Int, TypeExpr)] -> b -> b)
-> (b -> b -> b)
-> (CaseType -> b -> [c] -> b)
-> (TPattern -> b -> c)
-> (b -> TypeExpr -> b)
-> TExpr
-> b
trTExpr
  ((Int -> Expr) -> TypeExpr -> Int -> Expr
forall a b. a -> b -> a
const Int -> Expr
Var)
  ((Literal -> Expr) -> TypeExpr -> Literal -> Expr
forall a b. a -> b -> a
const Literal -> Expr
Lit)
  (\_ ct :: CombType
ct name :: QName
name args :: [Expr]
args -> CombType -> QName -> [Expr] -> Expr
Comb CombType
ct QName
name [Expr]
args)
  (\bs :: [((Int, TypeExpr), Expr)]
bs e :: Expr
e -> [(Int, Expr)] -> Expr -> Expr
Let ((((Int, TypeExpr), Expr) -> (Int, Expr))
-> [((Int, TypeExpr), Expr)] -> [(Int, Expr)]
forall a b. (a -> b) -> [a] -> [b]
map (\(v :: (Int, TypeExpr)
v, e' :: Expr
e') -> ((Int, TypeExpr) -> Int
forall a b. (a, b) -> a
fst (Int, TypeExpr)
v, Expr
e')) [((Int, TypeExpr), Expr)]
bs) Expr
e)
  (\vs :: [(Int, TypeExpr)]
vs e :: Expr
e -> [Int] -> Expr -> Expr
Free (((Int, TypeExpr) -> Int) -> [(Int, TypeExpr)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, TypeExpr) -> Int
forall a b. (a, b) -> a
fst [(Int, TypeExpr)]
vs) Expr
e)
  Expr -> Expr -> Expr
Or
  CaseType -> Expr -> [BranchExpr] -> Expr
Case
  (\pat :: TPattern
pat e :: Expr
e -> Pattern -> Expr -> BranchExpr
Branch (TPattern -> Pattern
genFlatPattern TPattern
pat) Expr
e)
  Expr -> TypeExpr -> Expr
Typed

genFlatPattern :: TPattern -> Pattern
genFlatPattern :: TPattern -> Pattern
genFlatPattern = (TypeExpr -> QName -> [(Int, TypeExpr)] -> Pattern)
-> (TypeExpr -> Literal -> Pattern) -> TPattern -> Pattern
forall b.
(TypeExpr -> QName -> [(Int, TypeExpr)] -> b)
-> (TypeExpr -> Literal -> b) -> TPattern -> b
trTPattern
  (\_ name :: QName
name args :: [(Int, TypeExpr)]
args -> QName -> [Int] -> Pattern
Pattern QName
name ([Int] -> Pattern) -> [Int] -> Pattern
forall a b. (a -> b) -> a -> b
$ ((Int, TypeExpr) -> Int) -> [(Int, TypeExpr)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, TypeExpr) -> Int
forall a b. (a, b) -> a
fst [(Int, TypeExpr)]
args)
  ((Literal -> Pattern) -> TypeExpr -> Literal -> Pattern
forall a b. a -> b -> a
const Literal -> Pattern
LPattern)

-- transforms a FlatCurry module to a FlatCurry interface
genFlatInterface :: Prog -> Prog
genFlatInterface :: Prog -> Prog
genFlatInterface =
  Update Prog [FuncDecl]
updProgFuncs Update Prog [FuncDecl] -> Update Prog [FuncDecl]
forall a b. (a -> b) -> a -> b
$ (FuncDecl -> FuncDecl) -> [FuncDecl] -> [FuncDecl]
forall a b. (a -> b) -> [a] -> [b]
map ((FuncDecl -> FuncDecl) -> [FuncDecl] -> [FuncDecl])
-> (FuncDecl -> FuncDecl) -> [FuncDecl] -> [FuncDecl]
forall a b. (a -> b) -> a -> b
$ Update FuncDecl Rule
updFuncRule Update FuncDecl Rule -> Update FuncDecl Rule
forall a b. (a -> b) -> a -> b
$ Rule -> Rule -> Rule
forall a b. a -> b -> a
const (Rule -> Rule -> Rule) -> Rule -> Rule -> Rule
forall a b. (a -> b) -> a -> b
$ [Int] -> Expr -> Rule
Rule [] (Expr -> Rule) -> Expr -> Rule
forall a b. (a -> b) -> a -> b
$ Int -> Expr
Var 0