------------------------------------------------------------------------------
--- Library to support meta-programming in Curry.
---
--- This library contains a definition for representing FlatCurry programs
--- in Haskell (type "Prog").
---
--- @author Michael Hanus
--- @version September 2003
---
--- Version for Haskell (slightly modified):
--- December 2004, Martin Engelke (men@informatik.uni-kiel.de)
---
--- Added part calls for constructors, Bernd Brassel, August 2005
--- Added source references, Bernd Brassel, May 2009
------------------------------------------------------------------------------
{-# LANGUAGE DeriveDataTypeable, RankNTypes #-}
module Curry.ExtendedFlat.Type(SrcRef,Prog(..),
QName(..), qnOf,mkQName,
Visibility(..),
TVarIndex, TypeDecl(..), ConsDecl(..), TypeExpr(..),
OpDecl(..), Fixity(..),
VarIndex(..), mkIdx, incVarIndex,
FuncDecl(..), Rule(..),
CaseType(..), CombType(..), Expr(..), BranchExpr(..),
Pattern(..), Literal(..),
readFlatCurry, readFlatInterface, readFlat,
writeFlatCurry,writeExtendedFlat,gshowsPrec
) where
import Data.List(intersperse)
import Control.Monad (liftM)
import Data.Generics hiding (Fixity)
import Data.Function(on)
import System.FilePath
import Curry.Base.Position (SrcRef)
import Curry.Files.Filenames(flatName, extFlatName)
import Curry.Files.PathUtils (writeModule, maybeReadModule)
------------------------------------------------------------------------------
-- Definition of data types for representing FlatCurry programs:
-- =============================================================
--- Data type for representing a Curry module in the intermediate form.
--- A value of this data type has the form
---
--- (Prog modname imports typedecls functions opdecls translation_table)
---
--- where modname: name of this module,
--- imports: list of modules names that are imported,
--- typedecls, opdecls, functions, translation of type names
--- and constructor/function names: see below
data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl]
deriving (Read, Show, Eq,Data,Typeable)
-------------------------------------------------------------------------
--- The data type for representing qualified names.
--- In FlatCurry all names are qualified to avoid name clashes.
--- The first component is the module name and the second component the
--- unqualified name as it occurs in the source program.
--- The additional information about source references and types should
--- be invisible for the normal usage of QName.
-------------------------------------------------------------------------
data QName = QName {srcRef :: Maybe SrcRef,
typeofQName :: Maybe TypeExpr,
modName :: String,
localName :: String} deriving (Data,Typeable)
instance Read QName where
readsPrec d r =
[ (QName r' t m n, s) | ((r', t, m, n),s) <- readsPrec d r ]
++ [ (mkQName nm,s) | (nm,s) <- readsPrec d r ]
instance Show QName where
showsPrec d (QName r t m n)
= showsPrec d (r,t,m,n)
instance Eq QName where (==) = (==) `on` qnOf
instance Ord QName where compare = compare `on` qnOf
mkQName :: (String,String) -> QName
mkQName = uncurry (QName Nothing Nothing)
qnOf :: QName -> (String,String)
qnOf QName{modName=m,localName=n} = (m,n)
-------------------------------------------------------------------------
--- The data type for representing variable names.
--- The additional information should
--- be invisible for the normal usage of VarIndex.
-------------------------------------------------------------------------
data VarIndex = VarIndex {
typeofVar :: Maybe TypeExpr,
idxOf :: Int
} deriving (Data,Typeable)
onIndex :: (Int -> Int) -> VarIndex -> VarIndex
onIndex f (VarIndex{ typeofVar = t, idxOf = x})
= VarIndex t (f x)
onIndexes :: (Int ->Int -> Int) -> VarIndex -> VarIndex -> VarIndex
onIndexes g x = VarIndex (typeofVar x) . (g `on` idxOf) x
mkIdx :: Int -> VarIndex
mkIdx = VarIndex Nothing
instance Read VarIndex where
readsPrec d r =
[ (mkIdx i,s) | (i,s) <- readsPrec d r ]
++ [ (VarIndex t i,s) | ((t,i),s) <- readsPrec d r ]
instance Show VarIndex where
showsPrec d (VarIndex t i)= showsPrec d (t,i)
instance Eq VarIndex where
(==) = (==) `on` idxOf
instance Ord VarIndex where
compare = compare `on` idxOf
instance Num VarIndex where
(+) = onIndexes (+)
(*) = onIndexes (*)
(-) = onIndexes (-)
abs = onIndex abs
signum = onIndex signum
fromInteger = mkIdx . fromInteger
incVarIndex :: VarIndex -> Int -> VarIndex
incVarIndex vi n = vi { idxOf = n + idxOf vi }
------------------------------------------------------------
--- Data type to specify the visibility of various entities.
------------------------------------------------------------
data Visibility = Public -- public (exported) entity
| Private -- private entity
deriving (Read, Show, Eq,Data,Typeable)
--- The data type for representing type variables.
--- They are represented by (TVar i) where i is a type variable index.
type TVarIndex = Int
--- Data type for representing definitions of algebraic data types.
---
--- A data type definition of the form
---
--- data t x1...xn = ...| c t1....tkc |...
---
--- is represented by the FlatCurry term
---
--- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...])
---
--- where each ij is the index of the type variable xj
---
--- Note: the type variable indices are unique inside each type declaration
--- and are usually numbered from 0
---
--- Thus, a data type declaration consists of the name of the data type,
--- a list of type parameters and a list of constructor declarations.
---
data TypeDecl = Type QName Visibility [TVarIndex] [ConsDecl]
| TypeSyn QName Visibility [TVarIndex] TypeExpr
deriving (Read, Show, Eq,Data,Typeable)
--- A constructor declaration consists of the name and arity of the
--- constructor and a list of the argument types of the constructor.
data ConsDecl = Cons QName Int Visibility [TypeExpr]
deriving (Read, Show, Eq,Data,Typeable)
--- Data type for type expressions.
--- A type expression is either a type variable, a function type,
--- or a type constructor application.
---
--- Note: the names of the predefined type constructors are
--- "Int", "Float", "Bool", "Char", "IO", "Success",
--- "()" (unit type), "(,...,)" (tuple types), "[]" (list type)
data TypeExpr =
TVar !TVarIndex -- type variable
| FuncType TypeExpr TypeExpr -- function type t1->t2
| TCons QName [TypeExpr] -- type constructor application
deriving (Read, Show, Eq,Data,Typeable) -- TCons module name typeargs
--- Data type for operator declarations.
--- An operator declaration "fix p n" in Curry corresponds to the
--- FlatCurry term (Op n fix p).
--- Note: the constructor definition of 'Op' differs from the original
--- PAKCS definition using Haskell type 'Integer' instead of 'Int'
--- for representing the precedence.
data OpDecl = Op QName Fixity Integer deriving (Read, Show, Eq,Data,Typeable)
--- Data types for the different choices for the fixity of an operator.
data Fixity = InfixOp | InfixlOp | InfixrOp deriving (Read, Show, Eq,Data,Typeable)
--- Data type for representing object variables.
--- Object variables occurring in expressions are represented by (Var i)
--- where i is a variable index.
--- Data type for representing function declarations.
---
--- A function declaration in FlatCurry is a term of the form
---
--- (Func name arity type (Rule [i_1,...,i_arity] e))
---
--- and represents the function "name" with definition
---
--- name :: type
--- name x_1...x_arity = e
---
--- where each i_j is the index of the variable x_j
---
--- Note: the variable indices are unique inside each function declaration
--- and are usually numbered from 0
---
--- External functions are represented as (Func name arity type (External s))
--- where s is the external name associated to this function.
---
--- Thus, a function declaration consists of the name, arity, type, and rule.
---
data FuncDecl = Func QName Int Visibility TypeExpr Rule
deriving (Read, Show, Eq,Data,Typeable)
--- A rule is either a list of formal parameters together with an expression
--- or an "External" tag.
data Rule = Rule [VarIndex] Expr
| External String
deriving (Read, Show, Eq,Data,Typeable)
--- Data type for classifying case expressions.
--- Case expressions can be either flexible or rigid in Curry.
data CaseType = Rigid | Flex deriving (Read, Show, Eq,Data,Typeable)
--- Data type for classifying combinations
--- (i.e., a function/constructor applied to some arguments).
--- @cons FuncCall - a call to a function all arguments are provided
--- @cons ConsCall - a call with a constructor at the top,
--- all arguments are provided
--- @cons FuncPartCall - a partial call to a function
--- (i.e., not all arguments are provided)
--- where the parameter is the number of
--- missing arguments
--- @cons ConsPartCall - a partial call to a constructor along with
--- number of missing arguments
data CombType = FuncCall
| ConsCall
| FuncPartCall Int
| ConsPartCall Int deriving (Read, Show, Eq,Data,Typeable)
--- Data type for representing expressions.
---
--- Remarks:
---
--- 1. if-then-else expressions are represented as function calls:
--- (if e1 then e2 else e3)
--- is represented as
--- (Comb FuncCall ("Prelude","if_then_else") [e1,e2,e3])
---
--- 2. Higher order applications are represented as calls to the (external)
--- function "apply". For instance, the rule
--- app f x = f x
--- is represented as
--- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1]))
---
--- 3. A conditional rule is represented as a call to an external function
--- "cond" where the first argument is the condition (a constraint).
--- For instance, the rule
--- equal2 x | x=:=2 = success
--- is represented as
--- (Rule [0]
--- (Comb FuncCall ("Prelude","cond")
--- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)],
--- Comb FuncCall ("Prelude","success") []]))
---
--- 4. Functions with evaluation annotation "choice" are represented
--- by a rule whose right-hand side is enclosed in a call to the
--- external function "Prelude.commit".
--- Furthermore, all rules of the original definition must be
--- represented by conditional expressions (i.e., (cond [c,e]))
--- after pattern matching.
--- Example:
---
--- m eval choice
--- m [] y = y
--- m x [] = x
---
--- is translated into (note that the conditional branches can be also
--- wrapped with Free declarations in general):
---
--- Rule [0,1]
--- (Comb FuncCall ("Prelude","commit")
--- [Or (Case Rigid (Var 0)
--- [(Pattern ("Prelude","[]") []
--- (Comb FuncCall ("Prelude","cond")
--- [Comb FuncCall ("Prelude","success") [],
--- Var 1]))] )
--- (Case Rigid (Var 1)
--- [(Pattern ("Prelude","[]") []
--- (Comb FuncCall ("Prelude","cond")
--- [Comb FuncCall ("Prelude","success") [],
--- Var 0]))] )])
---
--- Operational meaning of (Prelude.commit e):
--- evaluate e with local search spaces and commit to the first
--- (Comb FuncCall ("Prelude","cond") [c,ge]) in e whose constraint c
--- is satisfied
---
--- @cons Var - variable (represented by unique index)
--- @cons Lit - literal (Integer/Float/Char constant)
--- @cons Comb - application (f e1 ... en) of function/constructor f
--- with n<=arity(f)
--- @cons Free - introduction of free local variables
--- @cons Or - disjunction of two expressions (used to translate rules
--- with overlapping left-hand sides)
--- @cons Case - case distinction (rigid or flex)
data Expr = Var VarIndex
| Lit Literal
| Comb CombType QName [Expr]
| Free [VarIndex] Expr
| Let [(VarIndex,Expr)] Expr
| Or Expr Expr
| Case SrcRef CaseType Expr [BranchExpr]
deriving (Read, Show, Eq,Data,Typeable)
--- Data type for representing branches in a case expression.
---
--- Branches "(m.c x1...xn) -> e" in case expressions are represented as
---
--- (Branch (Pattern (m,c) [i1,...,in]) e)
---
--- where each ij is the index of the pattern variable xj, or as
---
--- (Branch (LPattern (Intc i)) e)
---
--- for integers as branch patterns (similarly for other literals
--- like float or character constants).
---
data BranchExpr = Branch Pattern Expr deriving (Read, Show, Eq,Data,Typeable)
--- Data type for representing patterns in case expressions.
data Pattern = Pattern QName [VarIndex]
| LPattern Literal
deriving (Read, Show, Eq,Data,Typeable)
--- Data type for representing literals occurring in an expression
--- or case branch. It is either an integer, a float, or a character constant.
--- Note: the constructor definition of 'Intc' differs from the original
--- PAKCS definition. It uses Haskell type 'Integer' instead of 'Int'
--- to provide an unlimited range of integer numbers. Furthermore
--- float values are represented with Haskell type 'Double' instead of
--- 'Float'.
data Literal = Intc SrcRef Integer
| Floatc SrcRef Double
| Charc SrcRef Char
deriving (Read, Show, Eq,Data,Typeable)
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- Reads an ExtendedFlat file (extension ".efc") and returns the corresponding
-- FlatCurry program term (type 'Prog') as a value of type 'Maybe'.
readFlatCurry :: FilePath -> IO (Maybe Prog)
readFlatCurry fn
= do let filename = flatName fn
readFlat filename
-- Reads a FlatInterface file (extension ".fint") and returns the
-- corresponding term (type 'Prog') as a value of type 'Maybe'.
readFlatInterface :: String -> IO (Maybe Prog)
readFlatInterface fn
= do let filename = replaceExtension fn ".fint"
readFlat filename
-- Reads a Flat file and returns the corresponding term (type 'Prog') as
-- a value of type 'Maybe'.
readFlat :: FilePath -> IO (Maybe Prog)
readFlat = liftM (fmap read) . maybeReadModule
-- Writes a FlatCurry program term into a file.
-- If the flag is set, it will be the hidden .curry sub directory.
writeFlatCurry :: Bool -> String -> Prog -> IO ()
writeFlatCurry inHiddenSubdir filename prog
= writeModule inHiddenSubdir filename (showFlatCurry' False prog)
-- Writes a FlatCurry program term with source references into a file.
-- If the flag is set, it will be the hidden .curry sub directory.
writeExtendedFlat :: Bool -> String -> Prog -> IO ()
writeExtendedFlat inHiddenSubdir filename prog =
writeModule inHiddenSubdir (extFlatName filename) (showFlatCurry' True prog)
showFlatCurry' :: Bool -> Prog -> String
showFlatCurry' b x = gshowsPrec b False x ""
gshowsPrec :: Data a => Bool -> Bool -> a -> ShowS
gshowsPrec showType d =
genericShowsPrec d `ext1Q` showsList
`ext2Q` showsTuple
`extQ` (const id :: SrcRef -> ShowS)
`extQ` (const id :: [SrcRef] -> ShowS)
`extQ` (shows :: String -> ShowS)
`extQ` (shows :: Char -> ShowS)
`extQ` showsQName d
`extQ` showsVarIndex d
where
showsQName :: Bool -> QName -> ShowS
showsQName d' qn@QName{modName=m,localName=n} =
if showType then showParen d' (shows qn{srcRef=Nothing})
else shows (m,n)
showsVarIndex :: Bool -> VarIndex -> ShowS
showsVarIndex d'
| showType = showParen d' . shows
| otherwise = shows . idxOf
genericShowsPrec :: Data a => Bool -> a -> ShowS
genericShowsPrec d' t = let args = intersperse (showChar ' ') $
gmapQ (gshowsPrec showType True) t in
showParen (d' && not (null args)) $
showString (showConstr (toConstr t)) .
(if null args then id else showChar ' ') .
foldr (.) id args
showsList :: Data a => [a] -> ShowS
showsList xs = showChar '[' .
foldr (.) (showChar ']')
(intersperse (showChar ',') $
map (gshowsPrec showType False) xs)
showsTuple :: (Data a,Data b) => (a,b) -> ShowS
showsTuple (x,y) = showChar '(' .
gshowsPrec showType False x .
showChar ',' .
gshowsPrec showType False y .
showChar ')'
newtype Q r a = Q (a -> r)
ext2Q :: (Data d, Typeable2 t) => (d -> q) ->
(forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
ext2Q def ext arg =
case dataCast2 (Q ext) of
Just (Q ext') -> ext' arg
Nothing -> def arg
------------------------------------------------------------------------------
------------------------------------------------------------------------------