{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}

-- | This module contains functions that translate Haskell quasiquotes into
-- internal representations of languages and passes as defined in "Nanopass.Internal.Representation".
-- This is done by first parsing an s-expression with "Text.SExpression",
-- and then recursively recognizing the components of that s-expression.
--
-- The primary entry points are 'parseLanguage' and TODO 'parsePass`.
-- Other recognizers are exported to serve as the promary source for
-- documentation about the grammar used in these quasiquotes.
module Nanopass.Internal.Parser
  (
  -- * Recognizers
    ParseResult
  , parseLanguage
  -- ** Base Languages
  , parseBaseLanguage
  , parseNonterm
  , parseProduction
  -- ** Language Modification
  , parseLangMod
  , parseNontermsEdit
  , parseProductionsEdit
  -- ** Shared Recognizers
  , parseLangLHS
  , parseNontermBody
  , parseProductionBody
  , parseType
  -- * Passes
  , parsePass
  -- * S-Expressions
  , getSexpr
  , Loc(..)
  , toUpColonName
  ) where

import Nanopass.Internal.Representation

import Control.Monad (forM)
import Data.Functor ((<&>))
import Nanopass.Internal.Error (Error(..))
import Text.Megaparsec (runParser',State(..),PosState(..),SourcePos(..),errorBundlePretty)
import Text.Megaparsec.Char (space1)
import Text.Megaparsec.Pos (defaultTabWidth,mkPos)
import Text.SExpression (SExpr(..),Parser,parseSExpr,def)

import qualified Data.Map as Map
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char.Lexer as P

------------------------------
------ Glue it together ------
------------------------------

type ParseResult = Either
  (Language 'Unvalidated UpName)  -- ^ base language defintion
  LangMod -- ^ modifications to a language

-- | @
-- Language ::= \<BaseLang\> | \<LangMod\>
-- @
--
-- * for @BaseLang@, see 'parseBaseLanguage'
-- * for @LangMod@, see 'parseLangMod'
parseLanguage :: (Loc, String) -> Either Error ParseResult
parseLanguage :: (Loc, [Char]) -> Either Error ParseResult
parseLanguage inp :: (Loc, [Char])
inp@(Loc
_, [Char]
orig) = do
  SExpr
sexpr <- (Loc, [Char]) -> Either Error SExpr
getSexpr (Loc, [Char])
inp
  case SExpr
sexpr of
    List (SExpr
_:Atom [Char]
"from":[SExpr]
_) -> LangMod -> ParseResult
forall a b. b -> Either a b
Right (LangMod -> ParseResult)
-> Either Error LangMod -> Either Error ParseResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> SExpr -> Either Error LangMod
parseLangMod [Char]
orig SExpr
sexpr
    SExpr
_ -> Language 'Unvalidated UpName -> ParseResult
forall a b. a -> Either a b
Left (Language 'Unvalidated UpName -> ParseResult)
-> Either Error (Language 'Unvalidated UpName)
-> Either Error ParseResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> SExpr -> Either Error (Language 'Unvalidated UpName)
parseBaseLanguage [Char]
orig SExpr
sexpr

---------------------------------
------ Recognize Languages ------
---------------------------------

-- | @
-- BaseLang ::=
--   (\<LangLHS\>        language name and type variables
--       \<string…\>     documentation
--       \<Nonterm…\>)   syntactic categories
-- @
--
-- * for @LangLHS@, see 'parseLangLHS'
-- * for @Nonterm@, see 'parseNonterm'
parseBaseLanguage :: String -> SExpr -> Either Error (Language 'Unvalidated UpName)
parseBaseLanguage :: [Char] -> SExpr -> Either Error (Language 'Unvalidated UpName)
parseBaseLanguage [Char]
originalProgram (List (SExpr
lhs:[SExpr]
rest)) = do
  (UpName
name, [LowName]
langParams) <- SExpr -> Either Error (UpName, [LowName])
parseLangLHS SExpr
lhs
  let langName :: Name 'Unvalidated UpName
langName = UpName -> Name 'Unvalidated UpName
forall n. n -> Name 'Unvalidated n
SourceName UpName
name
      ([[Char]]
docs, [SExpr]
nonterms_) = [SExpr] -> ([[Char]], [SExpr])
spanDocstrs [SExpr]
rest
  [Nonterm 'Unvalidated]
nontermList <- SExpr -> Either Error (Nonterm 'Unvalidated)
parseNonterm (SExpr -> Either Error (Nonterm 'Unvalidated))
-> [SExpr] -> Either Error [Nonterm 'Unvalidated]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [SExpr]
nonterms_
  let nonterms :: Map UpName (Nonterm 'Unvalidated)
nonterms = [(UpName, Nonterm 'Unvalidated)]
-> Map UpName (Nonterm 'Unvalidated)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UpName, Nonterm 'Unvalidated)]
 -> Map UpName (Nonterm 'Unvalidated))
-> [(UpName, Nonterm 'Unvalidated)]
-> Map UpName (Nonterm 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ [Nonterm 'Unvalidated]
nontermList [Nonterm 'Unvalidated]
-> (Nonterm 'Unvalidated -> (UpName, Nonterm 'Unvalidated))
-> [(UpName, Nonterm 'Unvalidated)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Nonterm 'Unvalidated
s -> (Nonterm 'Unvalidated
s.nontermName.name, Nonterm 'Unvalidated
s)
  Language 'Unvalidated UpName
-> Either Error (Language 'Unvalidated UpName)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Language
    { Name 'Unvalidated UpName
langName :: Name 'Unvalidated UpName
$sel:langName:Language :: Name 'Unvalidated UpName
langName
    , $sel:langInfo:Language :: LanguageInfo 'Unvalidated
langInfo = LanguageInfo
      { $sel:langParams:LanguageInfo :: [Name 'Unvalidated LowName]
langParams = LowName -> Name 'Unvalidated LowName
forall n. n -> Name 'Unvalidated n
SourceName (LowName -> Name 'Unvalidated LowName)
-> [LowName] -> [Name 'Unvalidated LowName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LowName]
langParams
      , Map UpName (Nonterm 'Unvalidated)
nonterms :: Map UpName (Nonterm 'Unvalidated)
$sel:nonterms:LanguageInfo :: Map UpName (Nonterm 'Unvalidated)
nonterms
      , $sel:originalProgram:LanguageInfo :: Maybe [Char]
originalProgram = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
originalProgram
      , $sel:baseDefdLang:LanguageInfo :: Maybe (Language 'Valid UpDotName)
baseDefdLang = Maybe (Language 'Valid UpDotName)
forall a. Maybe a
Nothing
      }
    }
parseBaseLanguage [Char]
_ SExpr
other = Error -> Either Error (Language 'Unvalidated UpName)
forall a b. a -> Either a b
Left (Error -> Either Error (Language 'Unvalidated UpName))
-> Error -> Either Error (Language 'Unvalidated UpName)
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectingLanguage SExpr
other

-- | @
-- LangLHS ::= \<UpCase\>                 language name, zero type variables
--          |  (\<UpCase\> \<LowCase…\>)    language name, type variables
-- @
--
-- * for @UpCase@, see 'toUpName'
-- * for @LowCase@, see 'toLowName'
parseLangLHS :: SExpr -> Either Error (UpName, [LowName])
parseLangLHS :: SExpr -> Either Error (UpName, [LowName])
parseLangLHS (Atom [Char]
str) = case [Char] -> Maybe UpName
toUpName [Char]
str of
  Just UpName
name -> (UpName, [LowName]) -> Either Error (UpName, [LowName])
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpName
name, [])
  Maybe UpName
Nothing -> Error -> Either Error (UpName, [LowName])
forall a b. a -> Either a b
Left (Error -> Either Error (UpName, [LowName]))
-> Error -> Either Error (UpName, [LowName])
forall a b. (a -> b) -> a -> b
$ [Char] -> Error
ExpectedLangName [Char]
str
parseLangLHS (List (Atom [Char]
str:[SExpr]
rest)) = do
  UpName
name <- case [Char] -> Maybe UpName
toUpName [Char]
str of
    Just UpName
name -> UpName -> Either Error UpName
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpName
name
    Maybe UpName
Nothing -> Error -> Either Error UpName
forall a b. a -> Either a b
Left (Error -> Either Error UpName) -> Error -> Either Error UpName
forall a b. (a -> b) -> a -> b
$ [Char] -> Error
ExpectedLangName [Char]
str
  [LowName]
tyVars <- [SExpr]
-> (SExpr -> Either Error LowName) -> Either Error [LowName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [SExpr]
rest ((SExpr -> Either Error LowName) -> Either Error [LowName])
-> (SExpr -> Either Error LowName) -> Either Error [LowName]
forall a b. (a -> b) -> a -> b
$ \case
    Atom [Char]
tvStr | Just LowName
tvName <- [Char] -> Maybe LowName
toLowName [Char]
tvStr -> LowName -> Either Error LowName
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LowName
tvName
    SExpr
it -> Error -> Either Error LowName
forall a b. a -> Either a b
Left (Error -> Either Error LowName) -> Error -> Either Error LowName
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectingTypeVariable SExpr
it
  (UpName, [LowName]) -> Either Error (UpName, [LowName])
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpName
name, [LowName]
tyVars)
parseLangLHS SExpr
it = Error -> Either Error (UpName, [LowName])
forall a b. a -> Either a b
Left (Error -> Either Error (UpName, [LowName]))
-> Error -> Either Error (UpName, [LowName])
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectedLangLHS SExpr
it

-- | @
-- Nonterm ::=
--   (\<UpCase\>             type name
--       \<string…\>         documentation
--       \<Production…\>)    constructor arguments
-- @
--
-- * for @UpCase@, see 'toUpName'
-- * for @Production@, see 'parseProduction'
parseNonterm :: SExpr -> Either Error (Nonterm 'Unvalidated)
parseNonterm :: SExpr -> Either Error (Nonterm 'Unvalidated)
parseNonterm (List (Atom [Char]
str:[SExpr]
rest)) = do
  UpName
nontermName <- case [Char] -> Maybe UpName
toUpName [Char]
str of
    Just UpName
name -> UpName -> Either Error UpName
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpName
name
    Maybe UpName
Nothing -> Error -> Either Error UpName
forall a b. a -> Either a b
Left (Error -> Either Error UpName) -> Error -> Either Error UpName
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedNontermName (SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just (SExpr -> Maybe SExpr) -> SExpr -> Maybe SExpr
forall a b. (a -> b) -> a -> b
$ [Char] -> SExpr
Atom [Char]
str)
  UpName -> [SExpr] -> Either Error (Nonterm 'Unvalidated)
parseNontermBody UpName
nontermName [SExpr]
rest
parseNonterm (List (SExpr
other:[SExpr]
_)) = Error -> Either Error (Nonterm 'Unvalidated)
forall a b. a -> Either a b
Left (Error -> Either Error (Nonterm 'Unvalidated))
-> Error -> Either Error (Nonterm 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedNontermName (SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just SExpr
other)
parseNonterm SExpr
other = Error -> Either Error (Nonterm 'Unvalidated)
forall a b. a -> Either a b
Left (Error -> Either Error (Nonterm 'Unvalidated))
-> Error -> Either Error (Nonterm 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectedNonterm SExpr
other

-- | Separated out from 'parseNonterm' because it is useful in 'parseNontermsEdit' as well.
parseNontermBody :: UpName -> [SExpr] -> Either Error (Nonterm 'Unvalidated)
parseNontermBody :: UpName -> [SExpr] -> Either Error (Nonterm 'Unvalidated)
parseNontermBody UpName
nontermName [SExpr]
rest = do
  let ([[Char]]
docs, [SExpr]
prods_) = [SExpr] -> ([[Char]], [SExpr])
spanDocstrs [SExpr]
rest
  [Production 'Unvalidated]
productionList <- SExpr -> Either Error (Production 'Unvalidated)
parseProduction (SExpr -> Either Error (Production 'Unvalidated))
-> [SExpr] -> Either Error [Production 'Unvalidated]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [SExpr]
prods_
  let productions :: Map UpName (Production 'Unvalidated)
productions = [(UpName, Production 'Unvalidated)]
-> Map UpName (Production 'Unvalidated)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UpName, Production 'Unvalidated)]
 -> Map UpName (Production 'Unvalidated))
-> [(UpName, Production 'Unvalidated)]
-> Map UpName (Production 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ [Production 'Unvalidated]
productionList [Production 'Unvalidated]
-> (Production 'Unvalidated -> (UpName, Production 'Unvalidated))
-> [(UpName, Production 'Unvalidated)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Production 'Unvalidated
p -> (Production 'Unvalidated
p.prodName.name, Production 'Unvalidated
p)
  Nonterm 'Unvalidated -> Either Error (Nonterm 'Unvalidated)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nonterm
    { $sel:nontermName:Nonterm :: Name 'Unvalidated UpName
nontermName = UpName -> Name 'Unvalidated UpName
forall n. n -> Name 'Unvalidated n
SourceName UpName
nontermName
    , Map UpName (Production 'Unvalidated)
productions :: Map UpName (Production 'Unvalidated)
$sel:productions:Nonterm :: Map UpName (Production 'Unvalidated)
productions
    }

-- | @
-- Production ::=
--   (\<UpCase\>        constructor name
--       \<string…\>    documentation
--       \<Type…\>)     constructor arguments
-- @
--
-- * for @UpCase@, see 'toUpName'
-- * for @Type@, see 'parseType'
parseProduction :: SExpr -> Either Error (Production 'Unvalidated)
parseProduction :: SExpr -> Either Error (Production 'Unvalidated)
parseProduction (List (Atom [Char]
ctorStr:[SExpr]
rest)) = do
  UpName
prodName <- case [Char] -> Maybe UpName
toUpName [Char]
ctorStr of
    Just UpName
name -> UpName -> Either Error UpName
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpName
name
    Maybe UpName
Nothing -> Error -> Either Error UpName
forall a b. a -> Either a b
Left (Error -> Either Error UpName) -> Error -> Either Error UpName
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedConstructorName (SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just (SExpr -> Maybe SExpr) -> SExpr -> Maybe SExpr
forall a b. (a -> b) -> a -> b
$ [Char] -> SExpr
Atom [Char]
ctorStr)
  UpName -> [SExpr] -> Either Error (Production 'Unvalidated)
parseProductionBody UpName
prodName [SExpr]
rest
parseProduction SExpr
other = Error -> Either Error (Production 'Unvalidated)
forall a b. a -> Either a b
Left (Error -> Either Error (Production 'Unvalidated))
-> Error -> Either Error (Production 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectedProduction SExpr
other

-- | Separated out from 'parseProduction' because it is useful in 'parseProductionsEdit' as well.
parseProductionBody :: UpName -> [SExpr] -> Either Error (Production 'Unvalidated)
parseProductionBody :: UpName -> [SExpr] -> Either Error (Production 'Unvalidated)
parseProductionBody UpName
prodName [SExpr]
rest = do
  let ([[Char]]
docs, [SExpr]
args) = [SExpr] -> ([[Char]], [SExpr])
spanDocstrs [SExpr]
rest
  [TypeDesc 'Unvalidated]
subterms <- SExpr -> Either Error (TypeDesc 'Unvalidated)
parseType (SExpr -> Either Error (TypeDesc 'Unvalidated))
-> [SExpr] -> Either Error [TypeDesc 'Unvalidated]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [SExpr]
args
  Production 'Unvalidated -> Either Error (Production 'Unvalidated)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Production
    { $sel:prodName:Production :: Name 'Unvalidated UpName
prodName = UpName -> Name 'Unvalidated UpName
forall n. n -> Name 'Unvalidated n
SourceName UpName
prodName
    , [TypeDesc 'Unvalidated]
subterms :: [TypeDesc 'Unvalidated]
$sel:subterms:Production :: [TypeDesc 'Unvalidated]
subterms
    }

-- | @
-- Type ::= \<lowCase name\>                 type parameter
--       |  \<UpColonName\>                  plain Haskell type (kind *)
--                                         or non-terminal (language parameters already applied)
--       |  (\<UpColonName\> \<Type…\>)        plain Haskell type application
--       |  (\'?\' \<Type\>)                   Maybe type
--       |  (\'*\' \<Type\>)                   List type
--       |  (\'+\' \<Type\>)                   NonEmpty type
--       |  () | (\'&\')                     unit type
--       |  (\'&\' \<Type\>)                   Only type TODO
--       |  (\'&\' \<Type\> \<Type\> \<Type…\>)    tuple types
-- @
--
--
-- * for @UpCase@, see 'toUpName'
-- * for @LowCase@, see 'toLowName'
-- * for @UpColonCase@, see 'toUpColonName'
parseType :: SExpr -> Either Error (TypeDesc 'Unvalidated)
parseType :: SExpr -> Either Error (TypeDesc 'Unvalidated)
parseType = \case
  Atom [Char]
str
    | Just UpDotName
name <- [Char] -> Maybe UpDotName
toUpColonName [Char]
str
      -> TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated))
-> TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ Name 'Unvalidated UpDotName
-> [TypeDesc 'Unvalidated] -> TypeDesc 'Unvalidated
forall (v :: Validate).
Name v UpDotName -> [TypeDesc v] -> TypeDesc v
CtorType (UpDotName -> Name 'Unvalidated UpDotName
forall n. n -> Name 'Unvalidated n
SourceName UpDotName
name) []
    | Just LowName
name <- [Char] -> Maybe LowName
toLowName [Char]
str
      -> TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated))
-> TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ Name 'Unvalidated LowName -> TypeDesc 'Unvalidated
forall (v :: Validate). Name v LowName -> TypeDesc v
VarType (LowName -> Name 'Unvalidated LowName
forall n. n -> Name 'Unvalidated n
SourceName LowName
name)
    | Bool
otherwise -> Error -> Either Error (TypeDesc 'Unvalidated)
forall a b. a -> Either a b
Left (Error -> Either Error (TypeDesc 'Unvalidated))
-> Error -> Either Error (TypeDesc 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ [Char] -> Error
ExpectingTypeNameOrVar [Char]
str
  List [] -> TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDesc 'Unvalidated
forall (v :: Validate). TypeDesc v
UnitType
  List [Atom [Char]
"?", SExpr
x] -> TypeDesc 'Unvalidated -> TypeDesc 'Unvalidated
forall (v :: Validate). TypeDesc v -> TypeDesc v
MaybeType (TypeDesc 'Unvalidated -> TypeDesc 'Unvalidated)
-> Either Error (TypeDesc 'Unvalidated)
-> Either Error (TypeDesc 'Unvalidated)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Either Error (TypeDesc 'Unvalidated)
parseType SExpr
x
  List [Atom [Char]
"*", SExpr
x] -> TypeDesc 'Unvalidated -> TypeDesc 'Unvalidated
forall (v :: Validate). TypeDesc v -> TypeDesc v
ListType (TypeDesc 'Unvalidated -> TypeDesc 'Unvalidated)
-> Either Error (TypeDesc 'Unvalidated)
-> Either Error (TypeDesc 'Unvalidated)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Either Error (TypeDesc 'Unvalidated)
parseType SExpr
x
  List [Atom [Char]
"+", SExpr
x] -> TypeDesc 'Unvalidated -> TypeDesc 'Unvalidated
forall (v :: Validate). TypeDesc v -> TypeDesc v
NonEmptyType (TypeDesc 'Unvalidated -> TypeDesc 'Unvalidated)
-> Either Error (TypeDesc 'Unvalidated)
-> Either Error (TypeDesc 'Unvalidated)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SExpr -> Either Error (TypeDesc 'Unvalidated)
parseType SExpr
x
  List (Atom [Char]
"&" : [SExpr]
xs_) -> case [SExpr]
xs_ of
    [] -> TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDesc 'Unvalidated
forall (v :: Validate). TypeDesc v
UnitType
    [SExpr
x] -> SExpr -> Either Error (TypeDesc 'Unvalidated)
parseType SExpr
x -- TODO Data.Tuple.Only
    (SExpr
x1:SExpr
x2:[SExpr]
xs) -> do
      TypeDesc 'Unvalidated
t1 <- SExpr -> Either Error (TypeDesc 'Unvalidated)
parseType SExpr
x1
      TypeDesc 'Unvalidated
t2 <- SExpr -> Either Error (TypeDesc 'Unvalidated)
parseType SExpr
x2
      [TypeDesc 'Unvalidated]
ts <- SExpr -> Either Error (TypeDesc 'Unvalidated)
parseType (SExpr -> Either Error (TypeDesc 'Unvalidated))
-> [SExpr] -> Either Error [TypeDesc 'Unvalidated]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [SExpr]
xs
      TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated))
-> TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ TypeDesc 'Unvalidated
-> TypeDesc 'Unvalidated
-> [TypeDesc 'Unvalidated]
-> TypeDesc 'Unvalidated
forall (v :: Validate).
TypeDesc v -> TypeDesc v -> [TypeDesc v] -> TypeDesc v
TupleType TypeDesc 'Unvalidated
t1 TypeDesc 'Unvalidated
t2 [TypeDesc 'Unvalidated]
ts
  List (SExpr
x:[SExpr]
xs) -> do
    UpDotName
ctor <- case SExpr
x of
      Atom [Char]
str | Just UpDotName
name <- [Char] -> Maybe UpDotName
toUpColonName [Char]
str -> UpDotName -> Either Error UpDotName
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpDotName
name
      SExpr
_ -> Error -> Either Error UpDotName
forall a b. a -> Either a b
Left (Error -> Either Error UpDotName)
-> Error -> Either Error UpDotName
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectedTypeConstructor SExpr
x
    [TypeDesc 'Unvalidated]
ts <- SExpr -> Either Error (TypeDesc 'Unvalidated)
parseType (SExpr -> Either Error (TypeDesc 'Unvalidated))
-> [SExpr] -> Either Error [TypeDesc 'Unvalidated]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [SExpr]
xs
    TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated))
-> TypeDesc 'Unvalidated -> Either Error (TypeDesc 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ Name 'Unvalidated UpDotName
-> [TypeDesc 'Unvalidated] -> TypeDesc 'Unvalidated
forall (v :: Validate).
Name v UpDotName -> [TypeDesc v] -> TypeDesc v
CtorType (UpDotName -> Name 'Unvalidated UpDotName
forall n. n -> Name 'Unvalidated n
SourceName UpDotName
ctor) [TypeDesc 'Unvalidated]
ts
  x :: SExpr
x@(ConsList [SExpr]
_ SExpr
_) -> Error -> Either Error (TypeDesc 'Unvalidated)
forall a b. a -> Either a b
Left (Error -> Either Error (TypeDesc 'Unvalidated))
-> Error -> Either Error (TypeDesc 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ConsListsDisallowed SExpr
x
  x :: SExpr
x@(Number Integer
_) -> Error -> Either Error (TypeDesc 'Unvalidated)
forall a b. a -> Either a b
Left (Error -> Either Error (TypeDesc 'Unvalidated))
-> Error -> Either Error (TypeDesc 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
UnexpectedLiteral SExpr
x
  x :: SExpr
x@(String [Char]
_) -> Error -> Either Error (TypeDesc 'Unvalidated)
forall a b. a -> Either a b
Left (Error -> Either Error (TypeDesc 'Unvalidated))
-> Error -> Either Error (TypeDesc 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
UnexpectedLiteral SExpr
x
  x :: SExpr
x@(Bool Bool
_) -> Error -> Either Error (TypeDesc 'Unvalidated)
forall a b. a -> Either a b
Left (Error -> Either Error (TypeDesc 'Unvalidated))
-> Error -> Either Error (TypeDesc 'Unvalidated)
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
UnexpectedLiteral SExpr
x

spanDocstrs :: [SExpr] -> ([String], [SExpr])
spanDocstrs :: [SExpr] -> ([[Char]], [SExpr])
spanDocstrs = [[Char]] -> [SExpr] -> ([[Char]], [SExpr])
loop []
  where
  loop :: [[Char]] -> [SExpr] -> ([[Char]], [SExpr])
loop [[Char]]
acc (String [Char]
str:[SExpr]
rest) = [[Char]] -> [SExpr] -> ([[Char]], [SExpr])
loop ([Char]
str[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[[Char]]
acc) [SExpr]
rest
  loop [[Char]]
acc [SExpr]
rest = ([[Char]] -> [[Char]]
forall a. [a] -> [a]
reverse [[Char]]
acc, [SExpr]
rest)

-----------------------------------
------ Language Modification ------
-----------------------------------

-- | @
-- LangMod ::=
--   (\<LangLHS\>             new language name and type variables
--         \'from\'           keyword
--         \<UpColon\>        base language name
--       \<string…\>          documentation
--       \<NontermsEdit…\>)   changes to the base language's syntactic categories
-- @
--
-- * for @LangLHS@, see 'parseLangLHS'
-- * for @UpColon@, see 'toUpColonName'
-- * for @NontermsEdit@, see 'parseNontermsEdit'
parseLangMod :: String -> SExpr -> Either Error LangMod
parseLangMod :: [Char] -> SExpr -> Either Error LangMod
parseLangMod [Char]
originalModProgram (List (SExpr
lhs:Atom [Char]
"from":[SExpr]
rest_)) = do
  (UpName
newLang, [LowName]
newParams) <- SExpr -> Either Error (UpName, [LowName])
parseLangLHS SExpr
lhs
  (UpDotName
baseLang, [SExpr]
rest) <- case [SExpr]
rest_ of
    (Atom [Char]
str):[SExpr]
rest | Just UpDotName
name <- [Char] -> Maybe UpDotName
toUpColonName [Char]
str -> (UpDotName, [SExpr]) -> Either Error (UpDotName, [SExpr])
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpDotName
name, [SExpr]
rest)
    SExpr
other:[SExpr]
_ -> Error -> Either Error (UpDotName, [SExpr])
forall a b. a -> Either a b
Left (Error -> Either Error (UpDotName, [SExpr]))
-> Error -> Either Error (UpDotName, [SExpr])
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectingBaseLanguage (SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just SExpr
other)
    [SExpr]
_ -> Error -> Either Error (UpDotName, [SExpr])
forall a b. a -> Either a b
Left (Error -> Either Error (UpDotName, [SExpr]))
-> Error -> Either Error (UpDotName, [SExpr])
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectingBaseLanguage Maybe SExpr
forall a. Maybe a
Nothing
  let ([[Char]]
docs, [SExpr]
edits_) = [SExpr] -> ([[Char]], [SExpr])
spanDocstrs [SExpr]
rest
  [NontermsEdit]
edits <- SExpr -> Either Error NontermsEdit
parseNontermsEdit (SExpr -> Either Error NontermsEdit)
-> [SExpr] -> Either Error [NontermsEdit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [SExpr]
edits_
  LangMod -> Either Error LangMod
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LangMod
    { UpDotName
baseLang :: UpDotName
$sel:baseLang:LangMod :: UpDotName
baseLang
    , UpName
newLang :: UpName
$sel:newLang:LangMod :: UpName
newLang
    , $sel:newParams:LangMod :: [Name 'Unvalidated LowName]
newParams = LowName -> Name 'Unvalidated LowName
forall n. n -> Name 'Unvalidated n
SourceName (LowName -> Name 'Unvalidated LowName)
-> [LowName] -> [Name 'Unvalidated LowName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LowName]
newParams
    , $sel:nontermsEdit:LangMod :: [NontermsEdit]
nontermsEdit = [NontermsEdit]
edits
    , $sel:originalModProgram:LangMod :: Maybe [Char]
originalModProgram = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
originalModProgram
    }
parseLangMod [Char]
_ SExpr
other = Error -> Either Error LangMod
forall a b. a -> Either a b
Left (Error -> Either Error LangMod) -> Error -> Either Error LangMod
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectingKwFromAfterLHS SExpr
other

-- | @
-- NontermsEdit
--   ::= (\'+\'                       add a syntactic category
--           \<UpCase\>                 new non-terminal name
--           \<string…\>                documentation
--           \<Production…\>)           constructors
--    |  (\'-\' \<UpCase\>)             remove a syntactic category by name
--    |  (\'*\'                       modify a syntactic category's productions
--           \<UpCase name\>            name of non-terminal to edit
--           \<ProductionsEdit…\>)      changes to the base language's non-terminal
-- @
--
-- * for @UpCase@, see 'toUpName'
-- * for @Production@, see 'parseProduction'
-- * for @ProductionsEdit@, see 'parseProductionsEdit'
parseNontermsEdit :: SExpr -> Either Error NontermsEdit
parseNontermsEdit :: SExpr -> Either Error NontermsEdit
parseNontermsEdit (List (Atom [Char]
"+":[SExpr]
rest_)) = do
  (UpName
nontermName, [SExpr]
rest) <- case [SExpr]
rest_ of
    (Atom [Char]
str):[SExpr]
rest | Just UpName
name <- [Char] -> Maybe UpName
toUpName [Char]
str -> (UpName, [SExpr]) -> Either Error (UpName, [SExpr])
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpName
name, [SExpr]
rest)
    SExpr
other:[SExpr]
_ -> Error -> Either Error (UpName, [SExpr])
forall a b. a -> Either a b
Left (Error -> Either Error (UpName, [SExpr]))
-> Error -> Either Error (UpName, [SExpr])
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedNontermName (SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just SExpr
other)
    [] -> Error -> Either Error (UpName, [SExpr])
forall a b. a -> Either a b
Left (Error -> Either Error (UpName, [SExpr]))
-> Error -> Either Error (UpName, [SExpr])
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedNontermName Maybe SExpr
forall a. Maybe a
Nothing
  Nonterm 'Unvalidated
nonterm <- UpName -> [SExpr] -> Either Error (Nonterm 'Unvalidated)
parseNontermBody UpName
nontermName [SExpr]
rest
  NontermsEdit -> Either Error NontermsEdit
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NontermsEdit -> Either Error NontermsEdit)
-> NontermsEdit -> Either Error NontermsEdit
forall a b. (a -> b) -> a -> b
$ Nonterm 'Unvalidated -> NontermsEdit
AddNonterm Nonterm 'Unvalidated
nonterm
parseNontermsEdit (List (Atom [Char]
"-":[SExpr]
rest_)) = do
  (UpName
nontermName, [SExpr]
rest) <- case [SExpr]
rest_ of
    (Atom [Char]
str):[SExpr]
rest | Just UpName
name <- [Char] -> Maybe UpName
toUpName [Char]
str -> (UpName, [SExpr]) -> Either Error (UpName, [SExpr])
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpName
name, [SExpr]
rest)
    SExpr
other:[SExpr]
_ -> Error -> Either Error (UpName, [SExpr])
forall a b. a -> Either a b
Left (Error -> Either Error (UpName, [SExpr]))
-> Error -> Either Error (UpName, [SExpr])
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedNontermName (SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just SExpr
other)
    [] -> Error -> Either Error (UpName, [SExpr])
forall a b. a -> Either a b
Left (Error -> Either Error (UpName, [SExpr]))
-> Error -> Either Error (UpName, [SExpr])
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedNontermName Maybe SExpr
forall a. Maybe a
Nothing
  case [SExpr]
rest of
    [] -> () -> Either Error ()
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    SExpr
x:[SExpr]
_ -> Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
UnexpectedSExprAfterDelete SExpr
x
  NontermsEdit -> Either Error NontermsEdit
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NontermsEdit -> Either Error NontermsEdit)
-> NontermsEdit -> Either Error NontermsEdit
forall a b. (a -> b) -> a -> b
$ UpName -> NontermsEdit
DelNonterm UpName
nontermName
parseNontermsEdit (List (Atom [Char]
"*":[SExpr]
rest_)) = do
  (UpName
nontermName, [SExpr]
rest) <- case [SExpr]
rest_ of
    (Atom [Char]
str):[SExpr]
rest | Just UpName
name <- [Char] -> Maybe UpName
toUpName [Char]
str -> (UpName, [SExpr]) -> Either Error (UpName, [SExpr])
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpName
name, [SExpr]
rest)
    SExpr
other:[SExpr]
_ -> Error -> Either Error (UpName, [SExpr])
forall a b. a -> Either a b
Left (Error -> Either Error (UpName, [SExpr]))
-> Error -> Either Error (UpName, [SExpr])
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedNontermName (SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just SExpr
other)
    [] -> Error -> Either Error (UpName, [SExpr])
forall a b. a -> Either a b
Left (Error -> Either Error (UpName, [SExpr]))
-> Error -> Either Error (UpName, [SExpr])
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedNontermName Maybe SExpr
forall a. Maybe a
Nothing
  [ProductionsEdit]
edits <- SExpr -> Either Error ProductionsEdit
parseProductionsEdit (SExpr -> Either Error ProductionsEdit)
-> [SExpr] -> Either Error [ProductionsEdit]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` [SExpr]
rest
  NontermsEdit -> Either Error NontermsEdit
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NontermsEdit -> Either Error NontermsEdit)
-> NontermsEdit -> Either Error NontermsEdit
forall a b. (a -> b) -> a -> b
$ UpName -> [ProductionsEdit] -> NontermsEdit
ModNonterm UpName
nontermName [ProductionsEdit]
edits
parseNontermsEdit (List (SExpr
other:[SExpr]
_)) = Error -> Either Error NontermsEdit
forall a b. a -> Either a b
Left (Error -> Either Error NontermsEdit)
-> Error -> Either Error NontermsEdit
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectingPlusMinusStar SExpr
other
parseNontermsEdit SExpr
other = Error -> Either Error NontermsEdit
forall a b. a -> Either a b
Left (Error -> Either Error NontermsEdit)
-> Error -> Either Error NontermsEdit
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectingNontermsEdit SExpr
other

-- | @
-- ProductionsEdit
--   ::= (\'+\'              add a production
--           \<UpCase\>        new constructor name
--           \<string…\>       documentation
--           \<Type…\>)        constructor arguments
--    |  (\'-\' \<UpCase\>)    remove a production by name
-- @
--
-- * for @UpCase@, see 'toUpName'
-- * for @Type@, see 'parseType'
parseProductionsEdit :: SExpr -> Either Error ProductionsEdit
parseProductionsEdit :: SExpr -> Either Error ProductionsEdit
parseProductionsEdit (List (Atom [Char]
"+":[SExpr]
rest_)) = do
  (UpName
prodName, [SExpr]
rest) <- case [SExpr]
rest_ of
    (Atom [Char]
str):[SExpr]
rest | Just UpName
name <- [Char] -> Maybe UpName
toUpName [Char]
str -> (UpName, [SExpr]) -> Either Error (UpName, [SExpr])
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpName
name, [SExpr]
rest)
    SExpr
other:[SExpr]
_ -> Error -> Either Error (UpName, [SExpr])
forall a b. a -> Either a b
Left (Error -> Either Error (UpName, [SExpr]))
-> Error -> Either Error (UpName, [SExpr])
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedConstructorName (SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just SExpr
other)
    [] -> Error -> Either Error (UpName, [SExpr])
forall a b. a -> Either a b
Left (Error -> Either Error (UpName, [SExpr]))
-> Error -> Either Error (UpName, [SExpr])
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedConstructorName Maybe SExpr
forall a. Maybe a
Nothing
  Production 'Unvalidated
prod <- UpName -> [SExpr] -> Either Error (Production 'Unvalidated)
parseProductionBody UpName
prodName [SExpr]
rest
  ProductionsEdit -> Either Error ProductionsEdit
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProductionsEdit -> Either Error ProductionsEdit)
-> ProductionsEdit -> Either Error ProductionsEdit
forall a b. (a -> b) -> a -> b
$ Production 'Unvalidated -> ProductionsEdit
AddProd Production 'Unvalidated
prod
parseProductionsEdit (List (Atom [Char]
"-":[SExpr]
rest_)) = do
  (UpName
prodName, [SExpr]
rest) <- case [SExpr]
rest_ of
    (Atom [Char]
str):[SExpr]
rest | Just UpName
name <- [Char] -> Maybe UpName
toUpName [Char]
str -> (UpName, [SExpr]) -> Either Error (UpName, [SExpr])
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpName
name, [SExpr]
rest)
    SExpr
other:[SExpr]
_ -> Error -> Either Error (UpName, [SExpr])
forall a b. a -> Either a b
Left (Error -> Either Error (UpName, [SExpr]))
-> Error -> Either Error (UpName, [SExpr])
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedConstructorName (SExpr -> Maybe SExpr
forall a. a -> Maybe a
Just SExpr
other)
    [] -> Error -> Either Error (UpName, [SExpr])
forall a b. a -> Either a b
Left (Error -> Either Error (UpName, [SExpr]))
-> Error -> Either Error (UpName, [SExpr])
forall a b. (a -> b) -> a -> b
$ Maybe SExpr -> Error
ExpectedConstructorName Maybe SExpr
forall a. Maybe a
Nothing
  case [SExpr]
rest of
    [] -> () -> Either Error ()
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    SExpr
x:[SExpr]
_ -> Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
UnexpectedSExprAfterDelete SExpr
x
  ProductionsEdit -> Either Error ProductionsEdit
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProductionsEdit -> Either Error ProductionsEdit)
-> ProductionsEdit -> Either Error ProductionsEdit
forall a b. (a -> b) -> a -> b
$ UpName -> ProductionsEdit
DelProd UpName
prodName
parseProductionsEdit (List (SExpr
other:[SExpr]
_)) = Error -> Either Error ProductionsEdit
forall a b. a -> Either a b
Left (Error -> Either Error ProductionsEdit)
-> Error -> Either Error ProductionsEdit
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectingPlusMinus SExpr
other
parseProductionsEdit SExpr
other = Error -> Either Error ProductionsEdit
forall a b. a -> Either a b
Left (Error -> Either Error ProductionsEdit)
-> Error -> Either Error ProductionsEdit
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectingProductionsEdit SExpr
other

---------------------------------
------ Parse S-Expressions ------
---------------------------------

-- | This is a location type that should be sufficient to describe the start of a Template Haskell quasiquote.
-- It is used in 'getSexpr' so that it can report errors from the actual source code location.
data Loc = Loc
  { Loc -> [Char]
file :: FilePath
  , Loc -> Int
line :: Int
  , Loc -> Int
col :: Int
  }

-- | This serves as an adapter between Template Haskell and whatever s-expression parser I decide to use.
getSexpr :: (Loc, String) -> Either Error SExpr
getSexpr :: (Loc, [Char]) -> Either Error SExpr
getSexpr (Loc
loc, [Char]
inp) = case Parsec Void [Char] SExpr
-> State [Char] Void
-> (State [Char] Void, Either (ParseErrorBundle [Char] Void) SExpr)
forall e s a.
Parsec e s a
-> State s e -> (State s e, Either (ParseErrorBundle s e) a)
runParser' (Parser ()
sc Parser () -> Parsec Void [Char] SExpr -> Parsec Void [Char] SExpr
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LiteralParsers -> Parsec Void [Char] SExpr
parseSExpr LiteralParsers
forall a. Default a => a
def Parsec Void [Char] SExpr -> Parser () -> Parsec Void [Char] SExpr
forall a b.
ParsecT Void [Char] Identity a
-> ParsecT Void [Char] Identity b -> ParsecT Void [Char] Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
sc) State [Char] Void
forall {e}. State [Char] e
state0 of
    (State [Char] Void
_, Left ParseErrorBundle [Char] Void
err) -> Error -> Either Error SExpr
forall a b. a -> Either a b
Left (Error -> Either Error SExpr)
-> ([Char] -> Error) -> [Char] -> Either Error SExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Error
SExprError ([Char] -> Either Error SExpr) -> [Char] -> Either Error SExpr
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle [Char] Void -> [Char]
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty ParseErrorBundle [Char] Void
err
    (State [Char] Void
_, Right SExpr
sexpr) -> SExpr -> Either Error SExpr
forall a b. b -> Either a b
Right SExpr
sexpr
  where
  sc :: Parser ()
  sc :: Parser ()
sc = Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
P.space Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 (Tokens [Char] -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
P.skipLineComment [Char]
Tokens [Char]
";") Parser ()
forall a. ParsecT Void [Char] Identity a
forall (f :: * -> *) a. Alternative f => f a
P.empty
  state0 :: State [Char] e
state0 = State
    { stateInput :: [Char]
stateInput = [Char]
inp
    , stateOffset :: Int
stateOffset = Int
0
    , statePosState :: PosState [Char]
statePosState = PosState
      { pstateInput :: [Char]
pstateInput = [Char]
inp
      , pstateOffset :: Int
pstateOffset = Int
0
      , pstateSourcePos :: SourcePos
pstateSourcePos = SourcePos
        { sourceName :: [Char]
sourceName = Loc
loc.file
        , sourceLine :: Pos
sourceLine = Int -> Pos
mkPos Loc
loc.line
        , sourceColumn :: Pos
sourceColumn = Int -> Pos
mkPos Loc
loc.col
        }
      , pstateTabWidth :: Pos
pstateTabWidth = Pos
defaultTabWidth
      , pstateLinePrefix :: [Char]
pstateLinePrefix = [Char]
""
      }
    , stateParseErrors :: [ParseError [Char] e]
stateParseErrors = []
    }

-- | Since sexprs don't allow dot in names, we use colon instead.
-- We just immediately translate it over into dots.
--
-- That is, accept strings matching @[A-Z][a-zA-Z0-9_]\(:[A-Z][a-zA-Z0-9_])*@,
-- and alter them with @s\/\\.\/:\/@.
toUpColonName :: String -> Maybe UpDotName
toUpColonName :: [Char] -> Maybe UpDotName
toUpColonName = [Char] -> Maybe UpDotName
toUpDotName ([Char] -> Maybe UpDotName)
-> ([Char] -> [Char]) -> [Char] -> Maybe UpDotName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' then Char
'.' else Char
c)

--------------------------
------ Parse Passes ------
--------------------------


-- | @
-- Pass
--   ::= (\'from\' \<UpColonCase\>    source lagnuage name
--        \'to\' \<UpColonCase\>      target lagnuage name
--          \<string…\>               documentation
-- @
--
-- * for @UpColonCase@, see 'toUpColonName'
parsePass :: (Loc, String) -> Either Error Pass
parsePass :: (Loc, [Char]) -> Either Error Pass
parsePass (Loc, [Char])
inp = SExpr -> Either Error Pass
parsePassSexpr (SExpr -> Either Error Pass)
-> Either Error SExpr -> Either Error Pass
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Loc, [Char]) -> Either Error SExpr
getSexpr (Loc, [Char])
inp

parsePassSexpr :: SExpr -> Either Error Pass
parsePassSexpr :: SExpr -> Either Error Pass
parsePassSexpr (List (Atom[Char]
"from":SExpr
l1:Atom [Char]
"to":SExpr
l2:[SExpr]
rest)) = do
  Name 'Unvalidated UpDotName
sourceLang <- case SExpr
l1 of
    Atom [Char]
str | Just UpDotName
name <- [Char] -> Maybe UpDotName
toUpColonName [Char]
str -> Name 'Unvalidated UpDotName
-> Either Error (Name 'Unvalidated UpDotName)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name 'Unvalidated UpDotName
 -> Either Error (Name 'Unvalidated UpDotName))
-> Name 'Unvalidated UpDotName
-> Either Error (Name 'Unvalidated UpDotName)
forall a b. (a -> b) -> a -> b
$ UpDotName -> Name 'Unvalidated UpDotName
forall n. n -> Name 'Unvalidated n
SourceName UpDotName
name
    SExpr
_ -> Error -> Either Error (Name 'Unvalidated UpDotName)
forall a b. a -> Either a b
Left (Error -> Either Error (Name 'Unvalidated UpDotName))
-> Error -> Either Error (Name 'Unvalidated UpDotName)
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectedUpDotNameAfterFrom SExpr
l1
  Name 'Unvalidated UpDotName
targetLang <- case SExpr
l2 of
    Atom [Char]
str | Just UpDotName
name <- [Char] -> Maybe UpDotName
toUpColonName [Char]
str -> Name 'Unvalidated UpDotName
-> Either Error (Name 'Unvalidated UpDotName)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name 'Unvalidated UpDotName
 -> Either Error (Name 'Unvalidated UpDotName))
-> Name 'Unvalidated UpDotName
-> Either Error (Name 'Unvalidated UpDotName)
forall a b. (a -> b) -> a -> b
$ UpDotName -> Name 'Unvalidated UpDotName
forall n. n -> Name 'Unvalidated n
SourceName UpDotName
name
    SExpr
_ -> Error -> Either Error (Name 'Unvalidated UpDotName)
forall a b. a -> Either a b
Left (Error -> Either Error (Name 'Unvalidated UpDotName))
-> Error -> Either Error (Name 'Unvalidated UpDotName)
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
ExpectedUpDotNameAfterTo SExpr
l2
  let ([[Char]]
docs, [SExpr]
after) = [SExpr] -> ([[Char]], [SExpr])
spanDocstrs [SExpr]
rest
  case [SExpr]
after of
    [] -> () -> Either Error ()
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [SExpr]
_ -> Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ UpDotName -> UpDotName -> Error
UnexpectedSExprAfterPass Name 'Unvalidated UpDotName
sourceLang.name Name 'Unvalidated UpDotName
targetLang.name
  Pass -> Either Error Pass
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Pass
    { Name 'Unvalidated UpDotName
sourceLang :: Name 'Unvalidated UpDotName
$sel:sourceLang:Pass :: Name 'Unvalidated UpDotName
sourceLang
    , Name 'Unvalidated UpDotName
targetLang :: Name 'Unvalidated UpDotName
$sel:targetLang:Pass :: Name 'Unvalidated UpDotName
targetLang
    }
parsePassSexpr SExpr
other = Error -> Either Error Pass
forall a b. a -> Either a b
Left (Error -> Either Error Pass) -> Error -> Either Error Pass
forall a b. (a -> b) -> a -> b
$ SExpr -> Error
MissingFromTo SExpr
other