Denormalize.hs

module Axel.Denormalize where

import Axel.Prelude

import Axel.AST
  ( Expression(ECaseBlock, EEmptySExpression, EFunctionApplication,
           EIdentifier, ELambda, ELetBlock, ELiteral, EPatternBinding,
           ERawExpression, ERecordDefinition, ERecordType)
  , Import(ImportItem, ImportType)
  , ImportSpecification(ImportAll, ImportOnly)
  , Literal(LChar, LFloat, LInt, LString)
  , SMExpression
  , SMStatement
  , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,
          SMacroImport, SModuleDeclaration, SNewtypeDeclaration, SPragma,
          SQualifiedImport, SRawStatement, SRestrictedImport, STopLevel,
          STypeSignature, STypeSynonym, STypeclassDefinition,
          STypeclassInstance)
  , TopLevel(TopLevel)
  , TypeDefinition(ProperType, TypeConstructor)
  , alias
  , arguments
  , bindings
  , body
  , constraints
  , constructors
  , definition
  , definitions
  , derivedConstraints
  , expr
  , fields
  , function
  , functionDefinition
  , getAnn'
  , imports
  , instanceName
  , matches
  , moduleName
  , name
  , pattern'
  , pragmaSpecification
  , signatures
  , typeDefinition
  , whereBindings
  , wrappedType
  )
import qualified Axel.Parse.AST as Parse
import qualified Axel.Sourcemap as SM
import Axel.Utils.List (unsafeHead)

import Control.Lens.Operators ((^.), (|>))

import qualified Data.Text as T

-- | Metadata is only approximately restored. Thus, `Axel.Normalize.normalizeExpression` and
-- | `denormalizeExpression` are only inverses if metadata information is
-- | ignored, although they should be pretty close either way.
denormalizeExpression :: SMExpression -> SM.Expression
denormalizeExpression (ECaseBlock caseBlock) =
  let ann' = getAnn' caseBlock
      denormalizedCases =
        map
          (\(pat, res) ->
             Parse.SExpression
               ann'
               [denormalizeExpression pat, denormalizeExpression res])
          (caseBlock ^. matches)
   in Parse.SExpression ann' $ Parse.Symbol ann' "case" :
      denormalizeExpression (caseBlock ^. expr) :
      denormalizedCases
denormalizeExpression expr'@(EEmptySExpression _) =
  Parse.SExpression (getAnn' expr') []
denormalizeExpression (EFunctionApplication functionApplication) =
  Parse.SExpression (getAnn' functionApplication) $
  denormalizeExpression (functionApplication ^. function) :
  map denormalizeExpression (functionApplication ^. arguments)
denormalizeExpression expr'@(EIdentifier _ x) =
  Parse.Symbol (getAnn' expr') (T.unpack x)
denormalizeExpression (ELambda lambda) =
  let ann' = getAnn' lambda
      denormalizedArguments =
        Parse.SExpression ann' $ Parse.Symbol ann' "list" :
        map denormalizeExpression (lambda ^. arguments)
   in Parse.SExpression
        ann'
        [ Parse.Symbol ann' "\\"
        , denormalizedArguments
        , denormalizeExpression (lambda ^. body)
        ]
denormalizeExpression (ELetBlock letBlock) =
  let ann' = getAnn' letBlock
      denormalizedBindings =
        Parse.SExpression ann' $ Parse.Symbol ann' "list" :
        map
          (\(var, val) ->
             Parse.SExpression
               ann'
               [denormalizeExpression var, denormalizeExpression val])
          (letBlock ^. bindings)
   in Parse.SExpression
        ann'
        [ Parse.Symbol ann' "let"
        , denormalizedBindings
        , denormalizeExpression (letBlock ^. body)
        ]
denormalizeExpression (ELiteral x) =
  case x of
    LChar _ char -> Parse.LiteralChar (getAnn' x) char
    LFloat _ float -> Parse.LiteralFloat (getAnn' x) float
    LInt _ int -> Parse.LiteralInt (getAnn' x) int
    LString _ string -> Parse.LiteralString (getAnn' x) (T.unpack string)
denormalizeExpression (EPatternBinding patternBinding) =
  let ann' = getAnn' patternBinding
   in Parse.SExpression
        ann'
        [ Parse.Symbol ann' "@"
        , denormalizeExpression (patternBinding ^. name)
        , denormalizeExpression (patternBinding ^. pattern')
        ]
denormalizeExpression expr'@(ERawExpression _ rawSource) =
  let ann' = getAnn' expr'
   in Parse.SExpression
        ann'
        [Parse.Symbol ann' "raw", Parse.LiteralString ann' (T.unpack rawSource)]
denormalizeExpression (ERecordDefinition recordDefinition) =
  let ann' = getAnn' recordDefinition
      denormalizedBindings =
        map
          (\(var, val) ->
             Parse.SExpression
               ann'
               [Parse.Symbol ann' (T.unpack var), denormalizeExpression val])
          (recordDefinition ^. bindings)
   in Parse.SExpression ann' (Parse.Symbol ann' "record" : denormalizedBindings)
denormalizeExpression (ERecordType recordType) =
  let ann' = getAnn' recordType
      denormalizedFields =
        map
          (\(field, ty) ->
             Parse.SExpression
               ann'
               [Parse.Symbol ann' (T.unpack field), denormalizeExpression ty])
          (recordType ^. fields)
   in Parse.SExpression
        ann'
        (Parse.Symbol ann' "recordType" : denormalizedFields)

denormalizeImportSpecification ::
     ImportSpecification (Maybe SM.Expression) -> SM.Expression
denormalizeImportSpecification importSpec@(ImportAll _) =
  Parse.Symbol (getAnn' importSpec) "all"
denormalizeImportSpecification importSpec@(ImportOnly _ importList) =
  let ann' = getAnn' importSpec
   in Parse.SExpression ann' $ Parse.Symbol ann' "list" :
      map denormalizeImport importList
  where
    denormalizeImport importList'@(ImportItem _ item) =
      Parse.Symbol (getAnn' importList') (T.unpack item)
    denormalizeImport importList'@(ImportType _ type' items) =
      let ann' = getAnn' importList'
       in Parse.SExpression
            ann'
            (Parse.Symbol ann' (T.unpack type') :
             map (Parse.Symbol ann' . T.unpack) items)

denormalizeStatement :: SMStatement -> SM.Expression
denormalizeStatement (SDataDeclaration dataDeclaration) =
  let ann' = getAnn' dataDeclaration
      denormalizedTypeDefinition =
        case dataDeclaration ^. typeDefinition of
          TypeConstructor _ typeConstructor ->
            denormalizeExpression $ EFunctionApplication typeConstructor
          ProperType _ properType ->
            Parse.Symbol
              (getAnn' $ dataDeclaration ^. typeDefinition)
              (T.unpack properType)
      denormalizedConstructors =
        map denormalizeExpression (dataDeclaration ^. constructors)
      denormalizedDerivedConstraintList =
        Parse.SExpression ann' $ Parse.Symbol ann' "list" :
        map denormalizeExpression (dataDeclaration ^. derivedConstraints)
   in Parse.SExpression ann' $ Parse.Symbol ann' "data" :
      denormalizedTypeDefinition :
      (denormalizedConstructors |> denormalizedDerivedConstraintList)
denormalizeStatement (SFunctionDefinition fnDef) =
  let ann' = getAnn' fnDef
   in Parse.SExpression ann' $ Parse.Symbol ann' "=" :
      Parse.SExpression
        ann'
        (Parse.Symbol ann' (T.unpack $ fnDef ^. name) :
         map denormalizeExpression (fnDef ^. arguments)) :
      denormalizeExpression (fnDef ^. body) :
      map denormalizeStatement (fnDef ^. whereBindings)
denormalizeStatement (SMacroDefinition macroDef) =
  let ann' = getAnn' macroDef
   in Parse.SExpression ann' $ Parse.Symbol ann' "=macro" :
      Parse.Symbol ann' (T.unpack $ macroDef ^. functionDefinition . name) :
      denormalizeExpression
        (unsafeHead $ macroDef ^. functionDefinition . arguments) :
      denormalizeExpression (macroDef ^. functionDefinition . body) :
      map denormalizeStatement (macroDef ^. functionDefinition . whereBindings)
denormalizeStatement (SMacroImport macroImport) =
  let ann' = getAnn' macroImport
   in Parse.SExpression
        ann'
        [ Parse.Symbol ann' "importm"
        , Parse.Symbol ann' (T.unpack $ macroImport ^. moduleName)
        , Parse.SExpression ann' $ Parse.Symbol ann' "list" :
          map (Parse.Symbol ann' . T.unpack) (macroImport ^. imports)
        ]
denormalizeStatement stmt@(SModuleDeclaration _ identifier) =
  let ann' = getAnn' stmt
   in Parse.SExpression
        ann'
        [Parse.Symbol ann' "module", Parse.Symbol ann' (T.unpack identifier)]
denormalizeStatement (SNewtypeDeclaration newtypeDeclaration) =
  let ann' = getAnn' newtypeDeclaration
      denormalizedTypeDefinition =
        case newtypeDeclaration ^. typeDefinition of
          TypeConstructor _ typeConstructor ->
            denormalizeExpression $ EFunctionApplication typeConstructor
          ProperType _ properType ->
            Parse.Symbol
              (getAnn' $ newtypeDeclaration ^. typeDefinition)
              (T.unpack properType)
      denormalizedDerivedConstraintList =
        Parse.SExpression ann' $ Parse.Symbol ann' "list" :
        map denormalizeExpression (newtypeDeclaration ^. derivedConstraints)
   in Parse.SExpression
        ann'
        [ Parse.Symbol ann' "newtype"
        , denormalizedTypeDefinition
        , denormalizeExpression $ newtypeDeclaration ^. wrappedType
        , denormalizedDerivedConstraintList
        ]
denormalizeStatement (SPragma pragma) =
  let ann' = getAnn' pragma
   in Parse.SExpression
        ann'
        [ Parse.Symbol ann' "pragma"
        , Parse.LiteralString ann' (T.unpack $ pragma ^. pragmaSpecification)
        ]
denormalizeStatement (SQualifiedImport qualifiedImport) =
  let ann' = getAnn' qualifiedImport
   in Parse.SExpression
        ann'
        [ Parse.Symbol ann' "importq"
        , Parse.Symbol ann' (T.unpack $ qualifiedImport ^. moduleName)
        , Parse.Symbol ann' (T.unpack $ qualifiedImport ^. alias)
        , denormalizeImportSpecification (qualifiedImport ^. imports)
        ]
denormalizeStatement expr'@(SRawStatement _ rawSource) =
  let ann' = getAnn' expr'
   in Parse.SExpression
        ann'
        [Parse.Symbol ann' "raw", Parse.LiteralString ann' (T.unpack rawSource)]
denormalizeStatement (SRestrictedImport restrictedImport) =
  let ann' = getAnn' restrictedImport
   in Parse.SExpression
        ann'
        [ Parse.Symbol ann' "import"
        , Parse.Symbol ann' (T.unpack $ restrictedImport ^. moduleName)
        , denormalizeImportSpecification (restrictedImport ^. imports)
        ]
denormalizeStatement stmt@(STopLevel (TopLevel _ statements)) =
  let ann' = getAnn' stmt
   in Parse.SExpression ann' $ Parse.Symbol ann' "begin" :
      map denormalizeStatement statements
denormalizeStatement (STypeclassDefinition typeclassDefinition) =
  let ann' = getAnn' typeclassDefinition
   in Parse.SExpression
        ann'
        (Parse.Symbol ann' "class" :
         Parse.SExpression
           ann'
           (Parse.Symbol ann' "list" :
            map denormalizeExpression (typeclassDefinition ^. constraints)) :
         denormalizeExpression (typeclassDefinition ^. name) :
         map
           (denormalizeStatement . STypeSignature)
           (typeclassDefinition ^. signatures))
denormalizeStatement (STypeclassInstance typeclassInstance) =
  let ann' = getAnn' typeclassInstance
   in Parse.SExpression
        ann'
        (Parse.Symbol ann' "instance" :
         Parse.SExpression
           ann'
           (Parse.Symbol ann' "list" :
            map denormalizeExpression (typeclassInstance ^. constraints)) :
         denormalizeExpression (typeclassInstance ^. instanceName) :
         map
           (denormalizeStatement . SFunctionDefinition)
           (typeclassInstance ^. definitions))
denormalizeStatement (STypeSignature typeSig) =
  let ann' = getAnn' typeSig
   in Parse.SExpression
        ann'
        [ Parse.Symbol ann' "::"
        , Parse.Symbol ann' (T.unpack $ typeSig ^. name)
        , Parse.SExpression
            ann'
            (Parse.Symbol ann' "list" :
             map denormalizeExpression (typeSig ^. constraints))
        , denormalizeExpression (typeSig ^. typeDefinition)
        ]
denormalizeStatement (STypeSynonym typeSynonym) =
  let ann' = getAnn' typeSynonym
   in Parse.SExpression
        ann'
        [ Parse.Symbol ann' "type"
        , denormalizeExpression (typeSynonym ^. alias)
        , denormalizeExpression (typeSynonym ^. definition)
        ]