Parse.hs

{-# LANGUAGE OverloadedStrings #-}

module Descript.Sugar.Parse
  ( parse
  , parseInputVal
  , parseOutputVal
  ) where

import Descript.Sugar.Parse.Refine
import Descript.Sugar.Data.Source hiding (query, amodule, importCtx, recordCtx, reduceCtx)
import Descript.Sugar.Data.Reducer hiding (input, output)
import qualified Descript.Sugar.Data.Value.In as In
import qualified Descript.Sugar.Data.Value.Out as Out
import Descript.Sugar.Data.Type
import Descript.Sugar.Data.Import hiding (moduleDecl)
import Descript.Free.Error
import qualified Descript.Free.Data as Free
import Descript.Misc
import Text.Megaparsec hiding (ParseError, parse)
import Core.Text.Megaparsec
import Data.Foldable
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Set as Set
import Prelude hiding (any)

type Parser a = Parsec RangedError (RangeStream Free.TopLevel) a
type RParser a = Parser (a Range)

-- | Parses a source file from the given file and contents.
parse :: ParseAction (RangeStream Free.TopLevel) (Source Range)
parse file = runLaterParser (source file) file

-- | Parses an individual input value from the given file and contents.
parseInputVal :: ParseAction (Free.Value Range) (In.Value Range)
parseInputVal file = refineResToParseRes file . freeToInput

-- | Parses an individual output value from the given file and contents.
parseOutputVal :: ParseAction (Free.Value Range) (Out.Value Range)
parseOutputVal file = refineResToParseRes file . freeToOutput

source :: SFile -> RParser Source
source file
    = ranged $ label "source"
    $ mkSource <$@> bmodule file <*@> optional query

bmodule :: SFile -> RParser BModule
bmodule file
    = ranged $ label "module"
    $ BModule <$@> importCtx file <*@> amodule

amodule :: RParser AModule
amodule
    = ranged
    $ AModule <$@> recordCtx <*@> reduceCtx

importCtx :: SFile -> RParser ImportCtx
importCtx file
    = ranged $ label "all imports"
    $ mkImportCtx file <$@> optional moduleDecl <*@> many importDecl

recordCtx :: RParser RecordCtx
recordCtx
    = ranged $ label "all record type declarations"
    $ RecordCtx <$@> many recordDecl

reduceCtx :: RParser ReduceCtx
reduceCtx
    = ranged $ label "all reducers"
    $ ReduceCtx <$@> phaseCtx `someSepBy` satisfy Free.topLevelIsPhaseSep

phaseCtx :: RParser PhaseCtx
phaseCtx
    = ranged $ label "all reducers in a particular phase"
    $ PhaseCtx <$@> many reducer

moduleDecl :: RParser ModuleDecl
moduleDecl
    = label "module declaration"
    $ mapSatisfy Free.topLevelToModuleDecl

importDecl :: Parser (AbsScope -> ImportDecl Range)
importDecl
    = label "import declaration"
    $ flip freeToImportDeclIn <$> mapSatisfy Free.topLevelToImportDecl

recordDecl :: RParser RecordDecl
recordDecl
    = absorbError $ label "record type eclaration"
    $ freeToRecordDecl <$> mapSatisfy Free.topLevelToRecordDecl

reducer :: RParser Reducer
reducer
    = absorbError $ label "reducer"
    $ freeToReducer <$> mapSatisfy Free.topLevelToReducer

query :: RParser Query
query
    = absorbError $ label "query"
    $ freeToQuery <$> mapSatisfy Free.topLevelToQuery

absorbError :: Parser (RefineResult (a Range)) -> RParser a
absorbError x = x >>= refineResToParser

refineResToParser :: RefineResult (a Range) -> RParser a
refineResToParser (Failure err) = refineDiffToParser err
refineResToParser (Success x) = pure x

refineResToParseRes :: SFile -> RefineResult a -> ParseResult a
refineResToParseRes = mapError . refineDiffToParseErr

refineDiffToParser :: RefineDiff -> Parser a
refineDiffToParser (RefineDiff diffs) = do
  filename <- sourceName <$> getPosition
  setPosition $ locToPos filename $ indivDiffsErrLoc diffs
  fancyFailure $ Set.fromList $ map indivDiffToFancyErr diffs

refineDiffToParseErr :: (Ord t) => SFile -> RefineDiff -> (ParseError t)
refineDiffToParseErr file (RefineDiff diffs)
  = FancyError posStack $ Set.fromList $ map indivDiffToFancyErr diffs
  where posStack = locToPos (sfileName file) (indivDiffsErrLoc diffs) :| []

indivDiffToFancyErr :: IndivRefineDiff -> ErrorFancy RangedError
indivDiffToFancyErr = ErrorCustom . indivDiffToRangedErr

indivDiffToRangedErr :: IndivRefineDiff -> RangedError
indivDiffToRangedErr (IndivRefineDiff range' local)
  = RangedError
  { errorRange = range'
  , rangedErrorExpected = expected local
    -- Don't want full summary - print handled by range
  , rangedErrorActual = actual local
  }

indivDiffsErrLoc :: [IndivRefineDiff] -> Loc
indivDiffsErrLoc = minimum . map (start . range)