AST.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Axel.AST where

import Axel.Prelude

import Axel.Haskell.Language (isOperator)
import Axel.Haskell.Macros (hygenisizeMacroName)
import qualified Axel.Parse.AST as Parse
import Axel.Sourcemap
  ( Bracket(CurlyBraces, Parentheses, SquareBrackets)
  , Delimiter(Commas, Newlines, Pipes, Spaces)
  )
import qualified Axel.Sourcemap as SM
  ( Expression
  , Output(Output)
  , SourceMetadata
  , delimit
  , renderBlock
  , surround
  )
import qualified Axel.Utils.Display as Display (delimit, renderPragma, surround)
import Axel.Utils.Tuple (annotate, unannotated)

import Control.Lens.Combinators (_head, _last)
import Control.Lens.Operators ((%~), (^.))
import Control.Lens.TH (makeFieldsNoPrefix, makePrisms)
import Control.Lens.Wrapped (_Wrapped)
import Control.Monad ((>=>))

import Data.Data (Data)
import qualified Data.Text as T

class ToHaskell a where
  toHaskell :: a -> SM.Output

type Identifier = Text

data CaseBlock ann =
  CaseBlock
    { _ann :: ann
    , _expr :: Expression ann -- ^ The expression being matched on.
    , _matches :: [(Expression ann, Expression ann)] -- ^ The (pattern, value) clauses.
    }
  deriving (Data, Eq, Functor, Show)

data FunctionApplication ann =
  FunctionApplication
    { _ann :: ann
    , _function :: Expression ann -- ^ The function being applied.
    , _arguments :: [Expression ann] -- ^ The arguments to the function.
    }
  deriving (Data, Eq, Functor, Show)

-- | This is so that macros can return multiple statements at the top-level without
--   pervasive use of `begin`- or `progn`-esque special forms. Because entire programs
--   are wrapped in this special form, individual macros are able to return multiple
--   forms directly (i.e. returning them as an array).
--
--   This should not be created, manipulated, etc. in Axel programs. It's generated and
--   manipulated internally, and using it directly in Axel programs should be considered
--   undefined behavior.
data TopLevel ann =
  TopLevel
    { _ann :: ann
    , _statements :: [Statement ann] -- ^ The top-level statements in the program.
    }
  deriving (Data, Eq, Functor, Show)

-- TODO Name this more clearly.
-- TODO Do `ProperType` and `TypeConstructor` need to be separate cases, since they only
--      differ in arity?
-- | The left-hand side of e.g. a @data@ clause (that is, @data <TypeDefinition> = ...@).
data TypeDefinition ann
  = ProperType ann Identifier -- ^ A type that has no arguments, e.g. @Foo@.
  | TypeConstructor ann (FunctionApplication ann) -- ^ A type with arguments, e.g. @Foo a@.
  deriving (Data, Eq, Functor, Show)

-- | An ADT definition.
data DataDeclaration ann =
  DataDeclaration
    { _ann :: ann
    , _typeDefinition :: TypeDefinition ann -- ^ The type being defined.
    , _constructors :: [Expression ann] -- ^ The data constructors.
    , _derivedConstraints :: [Expression ann] -- ^ The constraints to derive, e.g. @Eq@ and @Show@ in @data Foo = Foo deriving (Eq, Show)@.
    }
  deriving (Data, Eq, Functor, Show)

-- | A newtype definition.
data NewtypeDeclaration ann =
  NewtypeDeclaration
    { _ann :: ann
    , _typeDefinition :: TypeDefinition ann -- ^ The newtype being defined.
    , _wrappedType :: Expression ann -- ^ The old type being wrapped (for example, @Bar@ in @newtype Foo = Foo Bar@).
    , _derivedConstraints :: [Expression ann] -- ^ The constraints to derive, e.g. @Eq@ and @Show@ in @newtype Foo = Foo Bar deriving (Eq, Show)@.
    }
  deriving (Data, Eq, Functor, Show)

-- | A value-level definition.
data FunctionDefinition ann =
  FunctionDefinition
    { _ann :: ann
    , _name :: Identifier -- ^ The name of the function being defined.
    , _arguments :: [Expression ann] -- ^ The argument list of the function being defined.
    , _body :: Expression ann -- ^ The value the function is defined to compute.
    , _whereBindings :: [Statement ann] -- ^ The function's @where@-bindings.
    }
  deriving (Data, Eq, Functor, Show)

-- | An element of an import list.
data Import ann
  = ImportItem ann Identifier -- ^ An identifier to import.
  | ImportType ann Identifier [Identifier] -- ^ A type with sub-definitions, e.g @Foo(Bar, Baz)@.
  deriving (Data, Eq, Functor, Show)

-- | Specifies what to import from a module.
data ImportSpecification ann
  = ImportAll ann -- ^ Import everything from the module.
  | ImportOnly ann [Import ann] -- ^ Import only specific items from the module.
  deriving (Data, Eq, Functor, Show)

-- | A lambda expression.
data Lambda ann =
  Lambda
    { _ann :: ann
    , _arguments :: [Expression ann] -- ^ The arguments to the lambda.
    , _body :: Expression ann -- ^ The value computed by the lambda.
    }
  deriving (Data, Eq, Functor, Show)

-- | An as-pattern (e.g. @foo\@bar@).
data PatternBinding ann =
  PatternBinding
    { _ann :: ann
    , _name :: Expression ann -- ^ The name to bind the pattern to, e.g. @foo@ in @foo\@bar@.
    , _pattern' :: Expression ann -- ^ The pattern to be bound to the name, e.g. @bar@ in @foo\@bar@.
    }
  deriving (Data, Eq, Functor, Show)

-- | A @let@-block.
data LetBlock ann =
  LetBlock
    { _ann :: ann
    , _bindings :: [(Expression ann, Expression ann)]
    , _body :: Expression ann
    }
  deriving (Data, Eq, Functor, Show)

data MacroDefinition ann =
  MacroDefinition
    { _ann :: ann
    , _functionDefinition :: FunctionDefinition ann
    }
  deriving (Data, Eq, Functor, Show)

data MacroImport ann =
  MacroImport
    { _ann :: ann
    , _moduleName :: Identifier
    , _imports :: [Identifier]
    }
  deriving (Data, Eq, Functor, Show)

data Pragma ann =
  Pragma
    { _ann :: ann
    , _pragmaSpecification :: Text
    }
  deriving (Data, Eq, Functor, Show)

data QualifiedImport ann =
  QualifiedImport
    { _ann :: ann
    , _moduleName :: Identifier
    , _alias :: Identifier
    , _imports :: ImportSpecification ann
    }
  deriving (Data, Eq, Functor, Show)

data RecordDefinition ann =
  RecordDefinition
    { _ann :: ann
    , _bindings :: [(Identifier, Expression ann)]
    }
  deriving (Data, Eq, Functor, Show)

data RecordType ann =
  RecordType
    { _ann :: ann
    , _fields :: [(Identifier, Expression ann)]
    }
  deriving (Data, Eq, Functor, Show)

data RestrictedImport ann =
  RestrictedImport
    { _ann :: ann
    , _moduleName :: Identifier
    , _imports :: ImportSpecification ann
    }
  deriving (Data, Eq, Functor, Show)

data TypeclassDefinition ann =
  TypeclassDefinition
    { _ann :: ann
    , _name :: Expression ann
    , _constraints :: [Expression ann]
    , _signatures :: [TypeSignature ann]
    }
  deriving (Data, Eq, Functor, Show)

data TypeclassInstance ann =
  TypeclassInstance
    { _ann :: ann
    , _instanceName :: Expression ann
    , _constraints :: [Expression ann]
    , _definitions :: [FunctionDefinition ann]
    }
  deriving (Data, Eq, Functor, Show)

data TypeSignature ann =
  TypeSignature
    { _ann :: ann
    , _name :: Identifier
    , _constraints :: [Expression ann]
    , _typeDefinition :: Expression ann
    }
  deriving (Data, Eq, Functor, Show)

data TypeSynonym ann =
  TypeSynonym
    { _ann :: ann
    , _alias :: Expression ann
    , _definition :: Expression ann
    }
  deriving (Data, Eq, Functor, Show)

data Literal ann
  = LChar ann Char
  | LFloat ann Float
  | LInt ann Int
  | LString ann Text
  deriving (Data, Eq, Functor, Show)

data Expression ann
  = ECaseBlock (CaseBlock ann)
  | EEmptySExpression ann
  | EFunctionApplication (FunctionApplication ann)
  | EIdentifier ann Identifier
  | ELambda (Lambda ann)
  | ELetBlock (LetBlock ann)
  | ELiteral (Literal ann)
  | EPatternBinding (PatternBinding ann)
  | ERawExpression ann Text
  | ERecordDefinition (RecordDefinition ann)
  | ERecordType (RecordType ann)
  deriving (Data, Eq, Functor, Show)

data Statement ann
  = STopLevel (TopLevel ann)
  | SDataDeclaration (DataDeclaration ann)
  | SFunctionDefinition (FunctionDefinition ann)
  | SMacroDefinition (MacroDefinition ann)
  | SMacroImport (MacroImport ann)
  | SModuleDeclaration ann Identifier
  | SNewtypeDeclaration (NewtypeDeclaration ann)
  | SPragma (Pragma ann)
  | SQualifiedImport (QualifiedImport ann)
  | SRawStatement ann Text
  | SRestrictedImport (RestrictedImport ann)
  | STypeclassDefinition (TypeclassDefinition ann)
  | STypeclassInstance (TypeclassInstance ann)
  | STypeSignature (TypeSignature ann)
  | STypeSynonym (TypeSynonym ann)
  deriving (Data, Eq, Functor, Show)

type Program ann = [Statement ann]

makePrisms ''Expression

makePrisms ''Statement

makeFieldsNoPrefix ''CaseBlock

makeFieldsNoPrefix ''TopLevel

makeFieldsNoPrefix ''DataDeclaration

makeFieldsNoPrefix ''FunctionApplication

makeFieldsNoPrefix ''FunctionDefinition

makeFieldsNoPrefix ''Lambda

makeFieldsNoPrefix ''LetBlock

makeFieldsNoPrefix ''MacroDefinition

makeFieldsNoPrefix ''MacroImport

makeFieldsNoPrefix ''NewtypeDeclaration

makeFieldsNoPrefix ''Pragma

makeFieldsNoPrefix ''QualifiedImport

makeFieldsNoPrefix ''PatternBinding

makeFieldsNoPrefix ''RecordDefinition

makeFieldsNoPrefix ''RecordType

makeFieldsNoPrefix ''RestrictedImport

makeFieldsNoPrefix ''TypeclassDefinition

makeFieldsNoPrefix ''TypeclassInstance

makeFieldsNoPrefix ''TypeSignature

makeFieldsNoPrefix ''TypeSynonym

type SMExpression = Expression (Maybe SM.Expression)

type SMStatement = Statement (Maybe SM.Expression)

-- TODO Instead of using `HasAnnotation`, manually implement `HasAnn`
--      for everything instead.
class HasAnnotation a ann | a -> ann where
  getAnn :: a -> ann

-- TODO Figure out another way to do this,
--      since the current implementation needs overlapping instances.
instance {-# OVERLAPPABLE #-} (HasAnn a ann) => HasAnnotation a ann where
  getAnn :: a -> ann
  getAnn = (^. ann)

instance {-# OVERLAPPING #-} HasAnnotation (Expression ann) ann where
  getAnn :: Expression ann -> ann
  getAnn (ECaseBlock caseBlock) = caseBlock ^. ann
  getAnn (EEmptySExpression ann') = ann'
  getAnn (EFunctionApplication fnApp) = fnApp ^. ann
  getAnn (EIdentifier ann' _) = ann'
  getAnn (ELambda lambda) = lambda ^. ann
  getAnn (ELetBlock letBlock) = letBlock ^. ann
  getAnn (ELiteral literal) = getAnn literal
  getAnn (EPatternBinding patternBinding) = patternBinding ^. ann
  getAnn (ERawExpression ann' _) = ann'
  getAnn (ERecordDefinition recordDefinition) = recordDefinition ^. ann
  getAnn (ERecordType recordType) = recordType ^. ann

instance {-# OVERLAPPING #-} HasAnnotation (Statement ann) ann where
  getAnn :: Statement ann -> ann
  getAnn (STopLevel topLevel) = getAnn topLevel
  getAnn (SDataDeclaration dataDeclaration) = getAnn dataDeclaration
  getAnn (SFunctionDefinition fnDef) = getAnn fnDef
  getAnn (SMacroDefinition macroDef) = getAnn macroDef
  getAnn (SMacroImport macroImport) = getAnn macroImport
  getAnn (SModuleDeclaration ann' _) = ann'
  getAnn (SNewtypeDeclaration newtypeDeclaration) = getAnn newtypeDeclaration
  getAnn (SPragma pragma) = getAnn pragma
  getAnn (SQualifiedImport qualifiedImport) = getAnn qualifiedImport
  getAnn (SRawStatement ann' _) = ann'
  getAnn (SRestrictedImport restrictedImport) = getAnn restrictedImport
  getAnn (STypeclassDefinition typeclassDefinition) = getAnn typeclassDefinition
  getAnn (STypeclassInstance typeclassInstance) = getAnn typeclassInstance
  getAnn (STypeSignature typeSig) = getAnn typeSig
  getAnn (STypeSynonym typeSynonym) = getAnn typeSynonym

instance {-# OVERLAPPING #-} HasAnnotation (Parse.Expression ann) ann where
  getAnn :: Parse.Expression ann -> ann
  getAnn = Parse.getAnn

instance {-# OVERLAPPING #-} HasAnnotation (Literal ann) ann where
  getAnn :: Literal ann -> ann
  getAnn (LChar ann' _) = ann'
  getAnn (LFloat ann' _) = ann'
  getAnn (LInt ann' _) = ann'
  getAnn (LString ann' _) = ann'

instance {-# OVERLAPPING #-} HasAnnotation (TypeDefinition ann) ann where
  getAnn :: TypeDefinition ann -> ann
  getAnn (ProperType ann' _) = ann'
  getAnn (TypeConstructor ann' _) = ann'

instance {-# OVERLAPPING #-} HasAnnotation (ImportSpecification ann) ann where
  getAnn :: ImportSpecification ann -> ann
  getAnn (ImportAll ann') = ann'
  getAnn (ImportOnly ann' _) = ann'

instance {-# OVERLAPPING #-} HasAnnotation (Import ann) ann where
  getAnn :: Import ann -> ann
  getAnn (ImportItem ann' _) = ann'
  getAnn (ImportType ann' _ _) = ann'

-- | Get a nested annotation, where the higher-level annotation is behind a `Maybe`.
getAnn' :: (HasAnnotation a (Maybe SM.Expression)) => a -> SM.SourceMetadata
getAnn' = getAnn >=> getAnn

mkHaskell :: (HasAnnotation a (Maybe SM.Expression)) => a -> Text -> SM.Output
mkHaskell x haskellRendering = SM.Output [annotate (getAnn' x) haskellRendering]

instance ToHaskell SMStatement where
  toHaskell :: SMStatement -> SM.Output
  toHaskell (STopLevel xs) = toHaskell xs
  toHaskell (SDataDeclaration x) = toHaskell x
  toHaskell (SFunctionDefinition x) = toHaskell x
  toHaskell (SPragma x) = toHaskell x
  toHaskell (SMacroDefinition x) = toHaskell x
  toHaskell (SMacroImport x) = toHaskell x
  toHaskell stmt@(SModuleDeclaration _ x) =
    mkHaskell stmt $ "module " <> x <> " where"
  toHaskell (SNewtypeDeclaration x) = toHaskell x
  toHaskell (SQualifiedImport x) = toHaskell x
  toHaskell stmt@(SRawStatement _ x) = mkHaskell stmt x
  toHaskell (SRestrictedImport x) = toHaskell x
  toHaskell (STypeclassDefinition x) = toHaskell x
  toHaskell (STypeclassInstance x) = toHaskell x
  toHaskell (STypeSignature x) = toHaskell x
  toHaskell (STypeSynonym x) = toHaskell x

instance ToHaskell (TypeDefinition (Maybe SM.Expression)) where
  toHaskell :: TypeDefinition (Maybe SM.Expression) -> SM.Output
  toHaskell (TypeConstructor _ x) = toHaskell x
  toHaskell stmt@(ProperType _ x) = mkHaskell stmt x

instance ToHaskell (CaseBlock (Maybe SM.Expression)) where
  toHaskell :: CaseBlock (Maybe SM.Expression) -> SM.Output
  toHaskell caseBlock =
    SM.surround Parentheses $ mkHaskell caseBlock "case " <>
    toHaskell (caseBlock ^. expr) <>
    mkHaskell caseBlock " of " <>
    SM.renderBlock (map matchToHaskell (caseBlock ^. matches))
    where
      matchToHaskell (pat, result) =
        toHaskell pat <> mkHaskell caseBlock " -> " <> toHaskell result

instance ToHaskell (FunctionApplication (Maybe SM.Expression)) where
  toHaskell :: FunctionApplication (Maybe SM.Expression) -> SM.Output
  toHaskell functionApplication =
    case functionApplication ^. function of
      EIdentifier _ "list" ->
        SM.surround SquareBrackets $
        SM.delimit Commas (map toHaskell $ functionApplication ^. arguments)
      _ ->
        SM.surround Parentheses $ toHaskell (functionApplication ^. function) <>
        mkHaskell functionApplication " " <>
        SM.delimit Spaces (map toHaskell $ functionApplication ^. arguments)

instance ToHaskell (Literal (Maybe SM.Expression)) where
  toHaskell :: Literal (Maybe SM.Expression) -> SM.Output
  toHaskell literal@(LChar _ x) = mkHaskell literal $ showText x
  toHaskell literal@(LFloat _ x) = mkHaskell literal $ showText x
  toHaskell literal@(LInt _ x) = mkHaskell literal $ showText x
  toHaskell literal@(LString _ x) = mkHaskell literal $ showText x

instance ToHaskell (TypeSignature (Maybe SM.Expression)) where
  toHaskell :: TypeSignature (Maybe SM.Expression) -> SM.Output
  toHaskell typeSignature =
    toHaskell (EIdentifier (typeSignature ^. ann) (typeSignature ^. name)) <>
    mkHaskell typeSignature " :: " <>
    constraintsToHaskell (typeSignature ^. constraints) <>
    mkHaskell typeSignature " => " <>
    toHaskell (typeSignature ^. typeDefinition)

instance ToHaskell (FunctionDefinition (Maybe SM.Expression)) where
  toHaskell :: FunctionDefinition (Maybe SM.Expression) -> SM.Output
  toHaskell fnDef =
    toHaskell (EIdentifier (fnDef ^. ann) (fnDef ^. name)) <>
    mkHaskell fnDef " " <>
    SM.delimit Spaces (map toHaskell (fnDef ^. arguments)) <>
    mkHaskell fnDef " = " <>
    toHaskell (fnDef ^. body) <>
    auxBindings
    where
      auxBindings =
        if null (fnDef ^. whereBindings)
          then mempty
          else mkHaskell fnDef " where " <>
               SM.renderBlock (map toHaskell (fnDef ^. whereBindings))

instance ToHaskell (DataDeclaration (Maybe SM.Expression)) where
  toHaskell :: DataDeclaration (Maybe SM.Expression) -> SM.Output
  toHaskell dataDeclaration =
    mkHaskell dataDeclaration "data " <>
    toHaskell (dataDeclaration ^. typeDefinition) <>
    mkHaskell dataDeclaration " = " <>
    SM.delimit
      Pipes
      (map (tryRemoveSurroundingParentheses . toHaskell) $ dataDeclaration ^.
       constructors) <>
    mkHaskell dataDeclaration " deriving " <>
    SM.surround
      Parentheses
      (SM.delimit Commas $ map toHaskell $ dataDeclaration ^. derivedConstraints)
    where
      tryRemoveSurroundingParentheses :: SM.Output -> SM.Output
      tryRemoveSurroundingParentheses xs =
        if "(" `T.isPrefixOf` (xs ^. _Wrapped . _head . unannotated)
          then let removeOpen = _Wrapped . _head . unannotated %~ T.tail
                   removeClosed = _Wrapped . _last . unannotated %~ T.init
                in removeOpen $ removeClosed xs
          else xs

instance ToHaskell (NewtypeDeclaration (Maybe SM.Expression)) where
  toHaskell :: NewtypeDeclaration (Maybe SM.Expression) -> SM.Output
  toHaskell newtypeDeclaration =
    mkHaskell newtypeDeclaration "newtype " <>
    toHaskell (newtypeDeclaration ^. typeDefinition) <>
    mkHaskell newtypeDeclaration " = " <>
    constructor <>
    mkHaskell newtypeDeclaration " " <>
    toHaskell (newtypeDeclaration ^. wrappedType) <>
    mkHaskell newtypeDeclaration " deriving " <>
    SM.surround
      Parentheses
      (SM.delimit Commas $ map toHaskell $ newtypeDeclaration ^.
       derivedConstraints)
    where
      constructor =
        case newtypeDeclaration ^. typeDefinition of
          ProperType _ x -> mkHaskell newtypeDeclaration x
          TypeConstructor _ (FunctionApplication _ fn _) -> toHaskell fn

instance ToHaskell (Lambda (Maybe SM.Expression)) where
  toHaskell :: Lambda (Maybe SM.Expression) -> SM.Output
  toHaskell lambda =
    SM.surround Parentheses $ mkHaskell lambda "\\" <>
    SM.delimit Spaces (map toHaskell (lambda ^. arguments)) <>
    mkHaskell lambda " -> " <>
    toHaskell (lambda ^. body)

instance ToHaskell (Pragma (Maybe SM.Expression)) where
  toHaskell :: Pragma (Maybe SM.Expression) -> SM.Output
  toHaskell pragma =
    mkHaskell pragma $ Display.renderPragma (pragma ^. pragmaSpecification)

instance ToHaskell (PatternBinding (Maybe SM.Expression)) where
  toHaskell :: PatternBinding (Maybe SM.Expression) -> SM.Output
  toHaskell patternBinding =
    SM.surround Parentheses $ toHaskell (patternBinding ^. name) <>
    mkHaskell patternBinding "@" <>
    toHaskell (patternBinding ^. pattern')

instance ToHaskell (LetBlock (Maybe SM.Expression)) where
  toHaskell :: LetBlock (Maybe SM.Expression) -> SM.Output
  toHaskell letBlock =
    SM.surround Parentheses $ mkHaskell letBlock "let " <>
    SM.renderBlock (map bindingToHaskell (letBlock ^. bindings)) <>
    mkHaskell letBlock " in " <>
    toHaskell (letBlock ^. body)
    where
      bindingToHaskell (pat, val) =
        toHaskell pat <> mkHaskell letBlock " = " <> toHaskell val

instance ToHaskell (MacroDefinition (Maybe SM.Expression)) where
  toHaskell :: MacroDefinition (Maybe SM.Expression) -> SM.Output
  toHaskell macroDefinition = toHaskell (macroDefinition ^. functionDefinition)

instance ToHaskell (MacroImport (Maybe SM.Expression)) where
  toHaskell :: MacroImport (Maybe SM.Expression) -> SM.Output
  toHaskell macroImport =
    toHaskell $
    RestrictedImport
      (macroImport ^. ann)
      (macroImport ^. moduleName)
      (ImportOnly (macroImport ^. ann) $
       map (ImportItem (macroImport ^. ann) . hygenisizeMacroName) $
       macroImport ^.
       imports)

instance ToHaskell (ImportSpecification (Maybe SM.Expression)) where
  toHaskell :: ImportSpecification (Maybe SM.Expression) -> SM.Output
  toHaskell importSpec@(ImportAll _) = mkHaskell importSpec ""
  toHaskell (ImportOnly _ importList) =
    SM.surround Parentheses $ SM.delimit Commas $ map toHaskell importList

instance ToHaskell (QualifiedImport (Maybe SM.Expression)) where
  toHaskell :: QualifiedImport (Maybe SM.Expression) -> SM.Output
  toHaskell qualifiedImport =
    mkHaskell
      qualifiedImport
      ("import qualified " <> qualifiedImport ^. moduleName <> " as " <>
       qualifiedImport ^.
       alias) <>
    toHaskell (qualifiedImport ^. imports)

instance ToHaskell (Expression (Maybe SM.Expression)) where
  toHaskell :: Expression (Maybe SM.Expression) -> SM.Output
  toHaskell (ECaseBlock x) = toHaskell x
  toHaskell expr'@(EEmptySExpression _) = mkHaskell expr' "()"
  toHaskell (EFunctionApplication x) = toHaskell x
  toHaskell expr'@(EIdentifier _ x) =
    mkHaskell expr' $
    if isOperator $ T.unpack x
      then Display.surround Parentheses x
      else x
  toHaskell (ELambda x) = toHaskell x
  toHaskell (ELetBlock x) = toHaskell x
  toHaskell (ELiteral x) = toHaskell x
  toHaskell (EPatternBinding x) = toHaskell x
  toHaskell expr'@(ERawExpression _ x) = mkHaskell expr' x
  toHaskell (ERecordDefinition x) = toHaskell x
  toHaskell (ERecordType x) = toHaskell x

instance ToHaskell (RecordDefinition (Maybe SM.Expression)) where
  toHaskell :: RecordDefinition (Maybe SM.Expression) -> SM.Output
  toHaskell recordDefinition =
    SM.surround CurlyBraces $ SM.delimit Commas $
    map
      (\(var, val) -> mkHaskell recordDefinition (var <> " = ") <> toHaskell val)
      (recordDefinition ^. bindings)

instance ToHaskell (RecordType (Maybe SM.Expression)) where
  toHaskell :: RecordType (Maybe SM.Expression) -> SM.Output
  toHaskell recordDefinition =
    SM.surround CurlyBraces $ SM.delimit Commas $
    map
      (\(field, ty) ->
         mkHaskell recordDefinition (field <> " :: ") <> toHaskell ty)
      (recordDefinition ^. fields)

instance ToHaskell (Import (Maybe SM.Expression)) where
  toHaskell :: Import (Maybe SM.Expression) -> SM.Output
  toHaskell import'@(ImportItem _ x) =
    mkHaskell import' $
    if isOperator $ T.unpack x
      then Display.surround Parentheses x
      else x
  toHaskell import'@(ImportType _ typeName imports') =
    mkHaskell import' $ typeName <>
    Display.surround Parentheses (Display.delimit Commas imports')

instance ToHaskell (RestrictedImport (Maybe SM.Expression)) where
  toHaskell :: RestrictedImport (Maybe SM.Expression) -> SM.Output
  toHaskell restrictedImport =
    mkHaskell restrictedImport ("import " <> restrictedImport ^. moduleName) <>
    toHaskell (restrictedImport ^. imports)

instance ToHaskell (TopLevel (Maybe SM.Expression)) where
  toHaskell :: TopLevel (Maybe SM.Expression) -> SM.Output
  toHaskell topLevel =
    SM.delimit Newlines $ map toHaskell (topLevel ^. statements)

constraintsToHaskell :: [SMExpression] -> SM.Output
constraintsToHaskell =
  SM.surround Parentheses . SM.delimit Commas . map toHaskell

instance ToHaskell (TypeclassDefinition (Maybe SM.Expression)) where
  toHaskell :: TypeclassDefinition (Maybe SM.Expression) -> SM.Output
  toHaskell typeclassDefinition =
    mkHaskell typeclassDefinition "class " <>
    constraintsToHaskell (typeclassDefinition ^. constraints) <>
    mkHaskell typeclassDefinition " => " <>
    toHaskell (typeclassDefinition ^. name) <>
    mkHaskell typeclassDefinition " where " <>
    SM.renderBlock (map toHaskell $ typeclassDefinition ^. signatures)

instance ToHaskell (TypeclassInstance (Maybe SM.Expression)) where
  toHaskell :: TypeclassInstance (Maybe SM.Expression) -> SM.Output
  toHaskell typeclassInstance =
    mkHaskell typeclassInstance "instance " <>
    constraintsToHaskell (typeclassInstance ^. constraints) <>
    mkHaskell typeclassInstance " => " <>
    toHaskell (typeclassInstance ^. instanceName) <>
    mkHaskell typeclassInstance " where " <>
    SM.renderBlock (map toHaskell $ typeclassInstance ^. definitions)

instance ToHaskell (TypeSynonym (Maybe SM.Expression)) where
  toHaskell :: TypeSynonym (Maybe SM.Expression) -> SM.Output
  toHaskell typeSynonym =
    mkHaskell typeSynonym "type " <> toHaskell (typeSynonym ^. alias) <>
    mkHaskell typeSynonym " = " <>
    toHaskell (typeSynonym ^. definition)

statementsToProgram :: [SMStatement] -> SMStatement
statementsToProgram = STopLevel . TopLevel Nothing