Parse.hs

{-# LANGUAGE OverloadedStrings #-}

module Descript.Free.Parse
  ( parse
  , parseValue
  ) where

import Descript.Free.Data
import Descript.Lex hiding (parse)
import Descript.Misc
import Text.Megaparsec hiding (parse)
import Core.Text.Megaparsec
import qualified Data.List.NonEmpty as NonEmpty
import Prelude hiding (any)

type Parser a = Parsec RangedError (RangeStream Lex) a
type RParser a = Parser (a Range)

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

-- | Parses an individual value from the given file and contents.
parseValue :: ParseAction (RangeStream Lex) (Value Range)
parseValue = runLaterParser value

topLevels :: Parser (RangeStream TopLevel)
topLevels = topLevel `manySepBy` sep

topLevel :: RParser TopLevel
topLevel
    = label "top-level declaration"
    $ TopLevelModuleDecl <$> moduleDecl
  <|> TopLevelImportDecl <$> importDecl
  <|> ranged (TopLevelPhaseSep <$ phaseSep)
  <|> ranged (mkTopLevel <$@> value <*@> valueRefinement)

moduleDecl :: RParser ModuleDecl
moduleDecl
    = ranged $ label "module declaration"
    $ ModuleDecl <$@> (punc DeclModule *> modulePath)

importDecl :: RParser ImportDecl
importDecl
     = ranged $ label "import"
     $ mkImportDecl
  <$@> (punc DeclImport *> modulePath)
  <*@> optional srcImports
  <*@> optional dstImports

srcImports :: Parser [ImportRecord Range]
srcImports
     = label "\"[\" (followed by import records)"
     $ punc OpenBracket *> importRecord `manySepBy` sep <* punc CloseBracket

dstImports :: Parser [ImportRecord Range]
dstImports
     = label "\"{\" (followed by import records)"
     $ punc OpenBrace *> importRecord `manySepBy` sep <* punc CloseBrace

importRecord :: RParser ImportRecord
importRecord
    = ranged $ label "import record"
    $ mkImportRecord <$@> symbol <*@> optional (punc ArrowEqFwd *> symbol)

modulePath :: RParser ModulePath
modulePath
    = ranged $ label "module path"
    $ ModulePath <$@> symbol `someSepBy` punc PathFwd

phaseSep :: Parser ()
phaseSep = label "phase separator" $ punc PhaseSep

valueRefinement :: RParser ValueRefinement
valueRefinement
    = ToRecordDecl <$ punc Period
  <|> ToReducer <$> (punc Colon *> value)
  <|> ToQuery <$ punc Question

value :: RParser Value
value
    = ranged $ label "value"
    $ Value <$@> NonEmpty.toList <$> part `someSepBy` punc Union

part :: RParser Part
part
    = label "part"
    $ PartPrim <$> prim
  <|> PartRecord <$> record
  <|> PartPropPath <$> propPath

record :: RParser Record
record
     = ranged $ label "record"
     $ Record
  <$@> try (symbol <* punc OpenBracket)
  <*@> property `manySepBy` sep <* punc CloseBracket

property :: RParser Property
property
    = label "property"
    $ ranged (PropertyDef <$@> try (symbol <* punc Colon) <*@> value)
  <|> PropertySingle <$> value

propPath :: RParser PropPath
propPath
    = ranged $ label "property path"
    $ PropPath <$@> pathElem `someSepBy` punc PathFwd

pathElem :: RParser PathElem
pathElem
    = ranged $ label "path element"
    $ mkPathElem <$@> symbol <*@> optional (punc PathBwd *> symbol)

sep :: Parser ()
sep = punc Sep

punc :: (() -> Punc ()) -> Parser ()
punc = exactlyR . LexPunc . ($ ())

symbol :: RParser Symbol
symbol = mapSatisfy lexToSymbol

prim :: RParser Prim
prim = mapSatisfy lexToPrim