module Language.PureScript.Declarations where
import Language.PureScript.Types
import Language.PureScript.Names
import Language.PureScript.Kinds
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Environment
import qualified Data.Data as D
type Precedence = Integer
data Associativity = Infixl | Infixr | Infix deriving (D.Data, D.Typeable)
instance Show Associativity where
show Infixl = "infixl"
show Infixr = "infixr"
show Infix = "infix"
data SourcePos = SourcePos
{
sourceName :: String
, sourcePosLine :: Int
, sourcePosColumn :: Int
} deriving (D.Data, D.Typeable)
instance Show SourcePos where
show sp = (sourceName sp) ++ " line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)
data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
data DeclarationRef
= TypeRef ProperName (Maybe [ProperName])
| ValueRef Ident
| TypeClassRef ProperName
| TypeInstanceRef Ident
| PositionedDeclarationRef SourcePos DeclarationRef
deriving (Show, D.Data, D.Typeable)
instance Eq DeclarationRef where
(TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
(ValueRef name) == (ValueRef name') = name == name'
(TypeClassRef name) == (TypeClassRef name') = name == name'
(TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
(PositionedDeclarationRef _ r) == r' = r == r'
r == (PositionedDeclarationRef _ r') = r == r'
_ == _ = False
data Declaration
= DataDeclaration ProperName [String] [(ProperName, [Type])]
| DataBindingGroupDeclaration [Declaration]
| TypeSynonymDeclaration ProperName [String] Type
| TypeDeclaration Ident Type
| ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Value
| BindingGroupDeclaration [(Ident, NameKind, Value)]
| ExternDeclaration ForeignImportType Ident (Maybe JS) Type
| ExternDataDeclaration ProperName Kind
| ExternInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type]
| FixityDeclaration Fixity String
| ImportDeclaration ModuleName (Maybe [DeclarationRef]) (Maybe ModuleName)
| TypeClassDeclaration ProperName [String] [(Qualified ProperName, [Type])] [Declaration]
| TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]
| PositionedDeclaration SourcePos Declaration
deriving (Show, D.Data, D.Typeable)
isValueDecl :: Declaration -> Bool
isValueDecl ValueDeclaration{} = True
isValueDecl (PositionedDeclaration _ d) = isValueDecl d
isValueDecl _ = False
isDataDecl :: Declaration -> Bool
isDataDecl DataDeclaration{} = True
isDataDecl TypeSynonymDeclaration{} = True
isDataDecl (PositionedDeclaration _ d) = isDataDecl d
isDataDecl _ = False
isImportDecl :: Declaration -> Bool
isImportDecl ImportDeclaration{} = True
isImportDecl (PositionedDeclaration _ d) = isImportDecl d
isImportDecl _ = False
isExternDataDecl :: Declaration -> Bool
isExternDataDecl ExternDataDeclaration{} = True
isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d
isExternDataDecl _ = False
isExternInstanceDecl :: Declaration -> Bool
isExternInstanceDecl ExternInstanceDeclaration{} = True
isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d
isExternInstanceDecl _ = False
isFixityDecl :: Declaration -> Bool
isFixityDecl FixityDeclaration{} = True
isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d
isFixityDecl _ = False
isExternDecl :: Declaration -> Bool
isExternDecl ExternDeclaration{} = True
isExternDecl (PositionedDeclaration _ d) = isExternDecl d
isExternDecl _ = False
isTypeClassDeclaration :: Declaration -> Bool
isTypeClassDeclaration TypeClassDeclaration{} = True
isTypeClassDeclaration TypeInstanceDeclaration{} = True
isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d
isTypeClassDeclaration _ = False
type Guard = Value
data Value
= NumericLiteral (Either Integer Double)
| StringLiteral String
| BooleanLiteral Bool
| UnaryMinus Value
| BinaryNoParens (Qualified Ident) Value Value
| Parens Value
| ArrayLiteral [Value]
| ObjectLiteral [(String, Value)]
| Accessor String Value
| ObjectUpdate Value [(String, Value)]
| Abs (Either Ident Binder) Value
| App Value Value
| Var (Qualified Ident)
| IfThenElse Value Value Value
| Constructor (Qualified ProperName)
| Case [Value] [CaseAlternative]
| TypedValue Bool Value Type
| Let [Declaration] Value
| Do [DoNotationElement]
| TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]
| SuperClassDictionary (Qualified ProperName) [Type]
| PositionedValue SourcePos Value deriving (Show, D.Data, D.Typeable)
data CaseAlternative = CaseAlternative
{
caseAlternativeBinders :: [Binder]
, caseAlternativeGuard :: Maybe Guard
, caseAlternativeResult :: Value
} deriving (Show, D.Data, D.Typeable)
canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
data DoNotationElement
= DoNotationValue Value
| DoNotationBind Binder Value
| DoNotationLet [Declaration]
| PositionedDoNotationElement SourcePos DoNotationElement deriving (Show, D.Data, D.Typeable)
data Binder
= NullBinder
| BooleanBinder Bool
| StringBinder String
| NumberBinder (Either Integer Double)
| VarBinder Ident
| ConstructorBinder (Qualified ProperName) [Binder]
| ObjectBinder [(String, Binder)]
| ArrayBinder [Binder]
| ConsBinder Binder Binder
| NamedBinder Ident Binder
| PositionedBinder SourcePos Binder deriving (Show, D.Data, D.Typeable)
binderNames :: Binder -> [Ident]
binderNames = go []
where
go ns (VarBinder name) = name : ns
go ns (ConstructorBinder _ bs) = foldl go ns bs
go ns (ObjectBinder bs) = foldl go ns (map snd bs)
go ns (ArrayBinder bs) = foldl go ns bs
go ns (ConsBinder b1 b2) = go (go ns b1) b2
go ns (NamedBinder name b) = go (name : ns) b
go ns (PositionedBinder _ b) = go ns b
go ns _ = ns
everywhereOnValues :: (Declaration -> Declaration) ->
(Value -> Value) ->
(Binder -> Binder) ->
(Declaration -> Declaration, Value -> Value, Binder -> Binder)
everywhereOnValues f g h = (f', g', h')
where
f' :: Declaration -> Declaration
f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))
f' (ValueDeclaration name nameKind bs grd val) = f (ValueDeclaration name nameKind (map h' bs) (fmap g' grd) (g' val))
f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))
f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))
f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))
f' other = f other
g' :: Value -> Value
g' (UnaryMinus v) = g (UnaryMinus (g' v))
g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))
g' (Parens v) = g (Parens (g' v))
g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))
g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))
g' (Accessor prop v) = g (Accessor prop (g' v))
g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
g' (Abs name v) = g (Abs name (g' v))
g' (App v1 v2) = g (App (g' v1) (g' v2))
g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))
g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts))
g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)
g' (Let ds v) = g (Let (map f' ds) (g' v))
g' (Do es) = g (Do (map handleDoNotationElement es))
g' (PositionedValue pos v) = g (PositionedValue pos (g' v))
g' other = g other
h' :: Binder -> Binder
h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))
h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))
h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))
h' (NamedBinder name b) = h (NamedBinder name (h' b))
h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b))
h' other = h other
handleCaseAlternative :: CaseAlternative -> CaseAlternative
handleCaseAlternative ca =
ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
, caseAlternativeGuard = fmap g' (caseAlternativeGuard ca)
, caseAlternativeResult = g' (caseAlternativeResult ca)
}
handleDoNotationElement :: DoNotationElement -> DoNotationElement
handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)
handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)
handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)