{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TupleSections #-}

module Language.Nanopass.QQ
  ( deflang
  , defpass
  ) where

import Data.Char
import Language.Nanopass.LangDef
import Prelude hiding (mod)


import Control.Monad (forM)
import Language.Haskell.TH (Q, Dec)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Nanopass.Xlate (mkXlate)
import Text.Parse.Stupid (Sexpr(..))


import qualified Language.Haskell.TH as TH
import qualified Text.Parse.Stupid as Stupid

-- | Define a language, either from scratch or by derivation from an existing language.
-- The syntax is based on s-expressions. Whitespace doesn't matter, and a (full) line can be commented out with a hash (@#@).
-- More details and examples are given in the [readme](https://github.com/edemko/nanopass/blob/master/README.md).
--
-- We embed the syntax of the quasiquoters in a modified form of sexprs which allow---and distinguish between---square and curly brackets alongside round brackets.
-- Atoms are just sequences of characters that don't contain whitespace, though we only recognize a handful of these as valid syntactically.
-- Importantly, we treat symbols differently based on their shape:
--
--   * @UpCamelCase@ is used as in normal Haskell: to identify constructors, both type- and data-
--   * @$Name@ is used for recursive references to syntactic categories
--   * @lowerCamel@ is used for language parameters and the names of terms
--   * @DotSeparated.UpCamelCase@ is used to qualify the names of languages and types.
--   * a handful of operators are used
-- 
-- Since the syntax is based on s-expressions, we use [Scheme's entry format](https://schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-4.html#%_sec_1.3.3) conventions for describing the syntax.
-- Importantly, we syntactic variables are enclosed in @⟨angle brackets⟩@, and ellipsis @⟨thing⟩…@ indicate zero or more repetitions of @⟨thing⟩@.
-- Round, square, and curly brackets, as well as question mark, asterisk, and so on have no special meaning: they only denote themselves.
--
-- >  langdef
-- >    ::= ⟨language definition⟩
-- >     |  ⟨language modification⟩
-- >  
-- >  language definition
-- >    ::= ⟨UpName⟩ ( ⟨lowName⟩… ) ⟨syntactic category⟩…
-- >    ::= ⟨UpName⟩ ⟨syntactic category⟩…
-- >  
-- >  language modification
-- >    ::= ⟨Up.Name⟩ :-> ⟨UpName⟩ ( ⟨lowName⟩… ) ⟨syntactic category modifier⟩…
-- >     |  ⟨Up.Name⟩ :-> ⟨UpName⟩ ⟨syntactic category modifier⟩…
-- >  
-- >  syntactic category ::= ( ⟨UpName⟩ ⟨production⟩… )
-- >  production ::= ( ⟨UpName⟩ ⟨subterm⟩… )
-- >  subterm
-- >    ::= { ⟨lowName⟩ ⟨type⟩ }
-- >     |  ⟨type⟩
-- >  
-- >  type
-- >    ::= $⟨UpName⟩                               # reference a syntactic category
-- >     |  ⟨lowName⟩                               # type parameter
-- >     |  ( ⟨Up.Name⟩ ⟨type⟩… )                   # apply a Haskell Type constructor to arguments
-- >     |  ⟨Up.Name⟩                               # same as: (⟨UpName⟩)
-- >     |  ( ⟨type⟩ ⟨type operator⟩… )             # apply common type operators (left-associative)
-- >     |  ( ⟨Up.Name⟩ ⟨type⟩… ⟨type operator⟩… )  # same as: ((⟨UpName⟩ ⟨type⟩…) ⟨type operator⟩…)
-- >     |  { ⟨type⟩ ⟨type⟩ ⟨type⟩… }               # tuple type
-- >     |  [ ⟨type⟩ :-> ⟨type⟩ ]                   # association list: ({⟨type⟩ ⟨type⟩} *)
-- >     |  { ⟨type⟩ :-> ⟨type⟩ }                   # Data.Map
-- >  
-- >  type operator
-- >    ::= *  # []
-- >     |  +  # NonEmpty
-- >     |  ?  # Maybe
deflang :: QuasiQuoter
deflang :: QuasiQuoter
deflang = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter (String -> String -> Q Exp
forall {m :: * -> *} {p} {a}. MonadFail m => String -> p -> m a
bad String
"expression") (String -> String -> Q Pat
forall {m :: * -> *} {p} {a}. MonadFail m => String -> p -> m a
bad String
"pattern") (String -> String -> Q Type
forall {m :: * -> *} {p} {a}. MonadFail m => String -> p -> m a
bad String
"type") String -> Q [Dec]
go
  where
  go :: String -> Q [Dec]
  go :: String -> Q [Dec]
go String
input = do
    [Sexpr String]
sexprs <- case String -> Maybe [Sexpr String]
Stupid.parse String
input of
      Just [Sexpr String]
it -> [Sexpr String] -> Q [Sexpr String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Sexpr String]
it
      Maybe [Sexpr String]
Nothing -> String -> Q [Sexpr String]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"sexpr syntax error"
    case Maybe String
-> [Sexpr String] -> Either String (Either LangDef LangMod)
parseDefBaseOrExt (String -> Maybe String
forall a. a -> Maybe a
Just String
input) [Sexpr String]
sexprs of
      Right (Left LangDef
def) -> Define [Dec] -> Q [Dec]
forall a. Define a -> Q a
runDefine (Define [Dec] -> Q [Dec]) -> Define [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ LangDef -> Define [Dec]
defineLang LangDef
def
      Right (Right LangMod
mod) -> LangMod -> Q [Dec]
runModify LangMod
mod
      Left String
err -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
  bad :: String -> p -> m a
bad String
ctx p
_ = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"`deflang` quasiquoter cannot be used in a " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" context,\n\
                     \it can only appear as part of declarations."

-- | Define automatic translation between two langauges.
-- This creates an @Xlate@ type and the @descend\<Syntactic Category\>@ family of functions,
--   as well as pure variants (@XlateI@ and @descend\<Syntactic Category\>I@) and a lifting function @idXlate@.
-- A translation function is generated for each syntactic category with the same name in both source and target languages.
-- At the moment, there is no provision for altering the name of the type or translation function(s),
--   but I expect you'll only want to define one translation per module.
--
-- The @Xlate@ type takes all the parameters from both languages (de-duplicating parameters of the same name),
--   as well as an additional type parameter, which is the functor @f@ under which the translation occurs.
--
-- The type of a @descend\<Syntactic Category\>@ function is
--   @Xlate f → σ → f σ'@.
--
-- If a production in the source language has subterms @τ₁ … τₙ@ and is part of the syntactic category @σ@,
--   then a hole member is a function of type @τ₁ → … τₙ → f σ'@, where @σ'@ is the corresponding syntactic category in the target language.
-- Essentially, you get access all the subterms, and can use the 'Applicative' to generate a target term as long as you don't cross syntactic categories.
--
-- If a source language has syntactic category @σ@ with the same name as the target's syntactic category @σ'@,
--   then an override member is a function of type @σ → 'Maybe' (f σ')@.
-- If an override returns 'Nothing', then the automatic translation will be used,
--   otherwise the automatic translation is ignored in favor of the result under the 'Just'.
--
-- The pure variants have the same form as the 'Applicative' ones, but:
--
--   * @XlateI@ is not parameterized by @f@, nor are the types of its members,
--   * the members of @XlateI@ are suffixed with the letter @I@, and
--   * the types of the @descend\<Syntactic Category\>I@ functions are not parameterzed by @f@.
--
-- The @idXlate@ function is used by Nanopass to translate @XlateI@ values into @Xlate@ values.
-- This is done so that the same code paths can be used for both pure and 'Applicative' translations.
-- Under the hood, this is done with appropriate wrapping/unwrapping of v'Data.Functor.Identity.Identity', which is a no-op.
--
-- None of the functions defined by this quasiquoter need to be expoted for Nanopass to function.
-- I expect you will not export any of these definitions directly, but instead wrap them into a complete pass, and only export that pass.
--
-- More details and examples are given in the [readme](https://github.com/edemko/nanopass/blob/master/README.md).
--
-- The syntax is:
--
-- >  ⟨Up.Name⟩ :-> ⟨Up.Name⟩
defpass :: QuasiQuoter
defpass :: QuasiQuoter
defpass = (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter (String -> String -> Q Exp
forall {m :: * -> *} {p} {a}. MonadFail m => String -> p -> m a
bad String
"expression") (String -> String -> Q Pat
forall {m :: * -> *} {p} {a}. MonadFail m => String -> p -> m a
bad String
"pattern") (String -> String -> Q Type
forall {m :: * -> *} {p} {a}. MonadFail m => String -> p -> m a
bad String
"type") String -> Q [Dec]
go
  where
  go :: String -> Q [Dec]
go String
input = do
    [Sexpr String]
sexprs <- case String -> Maybe [Sexpr String]
Stupid.parse String
input of
      Just [Sexpr String]
it -> [Sexpr String] -> Q [Sexpr String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Sexpr String]
it
      Maybe [Sexpr String]
Nothing -> String -> Q [Sexpr String]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"sexpr syntax error"
    case [Sexpr String] -> Either String (String, String)
parseDefPass [Sexpr String]
sexprs of
      Right (String
l1Name, String
l2Name) -> do
        DefdLang
l1 <- String -> Q DefdLang
reifyLang String
l1Name
        DefdLang
l2 <- String -> Q DefdLang
reifyLang String
l2Name
        DefdLang -> DefdLang -> Q [Dec]
mkXlate DefdLang
l1 DefdLang
l2
      Left String
err -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
  bad :: String -> p -> m a
bad String
ctx p
_ = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"`defpass` quasiquoter cannot be used in a " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ctx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"context,\n\
                     \it can only appear as part of declarations."
  parseDefPass :: [Sexpr String] -> Either String (String, String)
  parseDefPass :: [Sexpr String] -> Either String (String, String)
parseDefPass [Atom String
l1, Atom String
":->", Atom String
l2]
    | Just String
l1Name <- String -> Maybe String
fromUpdotname String
l1
    , Just String
l2Name <- String -> Maybe String
fromUpdotname String
l2
      = (String, String) -> Either String (String, String)
forall a b. b -> Either a b
Right (String
l1Name, String
l2Name)
  parseDefPass [Sexpr String]
_ = String -> Either String (String, String)
forall a b. a -> Either a b
Left String
"expecting two language names, separated by :->"

----------------------------------
------ Language Definitions ------
----------------------------------

parseDefBaseOrExt :: Maybe String -> [Sexpr String] -> Either String (Either LangDef LangMod)
parseDefBaseOrExt :: Maybe String
-> [Sexpr String] -> Either String (Either LangDef LangMod)
parseDefBaseOrExt Maybe String
originalText (Sexpr String
langName:Atom String
":->":[Sexpr String]
rest) = case [Sexpr String]
rest of
  (Sexpr String
extName:[Sexpr String]
rest') -> case [Sexpr String]
rest' of
    (Sexpr String
candidateParams:[Sexpr String]
rest'') | Right [String]
params <- Sexpr String -> Either String [String]
parseParams Sexpr String
candidateParams
      -> LangMod -> Either LangDef LangMod
forall a b. b -> Either a b
Right (LangMod -> Either LangDef LangMod)
-> Either String LangMod -> Either String (Either LangDef LangMod)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> Sexpr String
-> Sexpr String
-> [String]
-> [Sexpr String]
-> Either String LangMod
parseLangMod Maybe String
originalText Sexpr String
langName Sexpr String
extName [String]
params [Sexpr String]
rest''
    [Sexpr String]
_ -> LangMod -> Either LangDef LangMod
forall a b. b -> Either a b
Right (LangMod -> Either LangDef LangMod)
-> Either String LangMod -> Either String (Either LangDef LangMod)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> Sexpr String
-> Sexpr String
-> [String]
-> [Sexpr String]
-> Either String LangMod
parseLangMod Maybe String
originalText Sexpr String
langName Sexpr String
extName [] [Sexpr String]
rest'
  [Sexpr String]
_ -> String -> Either String (Either LangDef LangMod)
forall a b. a -> Either a b
Left (String -> Either String (Either LangDef LangMod))
-> String -> Either String (Either LangDef LangMod)
forall a b. (a -> b) -> a -> b
$ String
"expecting a new language name"
parseDefBaseOrExt Maybe String
originalText (Sexpr String
langName:[Sexpr String]
rest) = case [Sexpr String]
rest of
  (Sexpr String
candidateParams:[Sexpr String]
rest') | Right [String]
params <- Sexpr String -> Either String [String]
parseParams Sexpr String
candidateParams
    -> LangDef -> Either LangDef LangMod
forall a b. a -> Either a b
Left (LangDef -> Either LangDef LangMod)
-> Either String LangDef -> Either String (Either LangDef LangMod)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> Sexpr String
-> [String]
-> [Sexpr String]
-> Either String LangDef
parseLangDef Maybe String
originalText Sexpr String
langName [String]
params [Sexpr String]
rest'
  [Sexpr String]
_ -> LangDef -> Either LangDef LangMod
forall a b. a -> Either a b
Left (LangDef -> Either LangDef LangMod)
-> Either String LangDef -> Either String (Either LangDef LangMod)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> Sexpr String
-> [String]
-> [Sexpr String]
-> Either String LangDef
parseLangDef Maybe String
originalText Sexpr String
langName [] [Sexpr String]
rest
parseDefBaseOrExt Maybe String
_ [Sexpr String]
_ = String -> Either String (Either LangDef LangMod)
forall a b. a -> Either a b
Left (String -> Either String (Either LangDef LangMod))
-> String -> Either String (Either LangDef LangMod)
forall a b. (a -> b) -> a -> b
$ String
"expecting a langauge name"

parseParams :: Sexpr String -> Either String [String]
parseParams :: Sexpr String -> Either String [String]
parseParams (Combo String
"(" [Sexpr String]
params) = Sexpr String -> Either String String
parseParam (Sexpr String -> Either String String)
-> [Sexpr String] -> Either String [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [Sexpr String]
params
  where
  parseParam :: Sexpr String -> Either String String
parseParam (Atom String
str) | Just String
param <- String -> Maybe String
fromLowername String
str = String -> Either String String
forall a b. b -> Either a b
Right String
param
  parseParam Sexpr String
other = String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String
"expecting type parameter (lowercase symbol), got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sexpr String -> String
forall a. Show a => a -> String
show Sexpr String
other
parseParams Sexpr String
other = String -> Either String [String]
forall a b. a -> Either a b
Left (String -> Either String [String])
-> String -> Either String [String]
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"expecting parameter list:\n"
  , String
"  (<lowercase name…> )\n"
  , String
"got:\n"
  , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Sexpr String -> String
forall a. Show a => a -> String
show Sexpr String
other
  ]

parseLangDef :: Maybe String -> Sexpr String -> [String] -> [Sexpr String] -> Either String LangDef
parseLangDef :: Maybe String
-> Sexpr String
-> [String]
-> [Sexpr String]
-> Either String LangDef
parseLangDef Maybe String
originalProgram Sexpr String
nameExpr [String]
langParamReqs [Sexpr String]
syncatExprs = do
  String
langNameReq <- Sexpr String -> Either String String
parseLangName Sexpr String
nameExpr
  [SyncatDef]
syncatReqs <- Sexpr String -> Either String SyncatDef
parseSyncat (Sexpr String -> Either String SyncatDef)
-> [Sexpr String] -> Either String [SyncatDef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [Sexpr String]
syncatExprs
  LangDef -> Either String LangDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LangDef -> Either String LangDef)
-> LangDef -> Either String LangDef
forall a b. (a -> b) -> a -> b
$ LangDef
    { String
langNameReq :: String
langNameReq :: String
langNameReq
    , [String]
langParamReqs :: [String]
langParamReqs :: [String]
langParamReqs
    , [SyncatDef]
syncatReqs :: [SyncatDef]
syncatReqs :: [SyncatDef]
syncatReqs
    , Maybe String
originalProgram :: Maybe String
originalProgram :: Maybe String
originalProgram
    , baseDefdLang :: Maybe DefdLang
baseDefdLang = Maybe DefdLang
forall a. Maybe a
Nothing
    }

parseLangName :: Sexpr String -> Either String String
parseLangName :: Sexpr String -> Either String String
parseLangName (Atom String
str) | Just String
str' <- String -> Maybe String
fromUpname String
str = String -> Either String String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
str'
parseLangName Sexpr String
_ = String -> Either String String
forall a b. a -> Either a b
Left String
"language name must be an UpCase alphanumeric symbol"

parseSyncat :: Sexpr String -> Either String SyncatDef
parseSyncat :: Sexpr String -> Either String SyncatDef
parseSyncat (Combo String
"(" (Sexpr String
nameExpr:[Sexpr String]
prodExprs)) = do
  String
sName <- case Sexpr String
nameExpr of
    (Atom String
nameStr) | Just String
sName <- String -> Maybe String
fromUpname String
nameStr -> String -> Either String String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
sName
    Sexpr String
_ -> String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"expecting an uppercase name of a syntactic category, got:\n"
      , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> Sexpr String -> String
forall a. (a -> String) -> Sexpr a -> String
Stupid.print String -> String
forall a. a -> a
id Sexpr String
nameExpr
      ]
  [ProdDef]
prods <- Sexpr String -> Either String ProdDef
parseProd (Sexpr String -> Either String ProdDef)
-> [Sexpr String] -> Either String [ProdDef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [Sexpr String]
prodExprs
  SyncatDef -> Either String SyncatDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SyncatDef -> Either String SyncatDef)
-> SyncatDef -> Either String SyncatDef
forall a b. (a -> b) -> a -> b
$ String -> [ProdDef] -> SyncatDef
SyncatDef String
sName [ProdDef]
prods
parseSyncat Sexpr String
other = String -> Either String SyncatDef
forall a b. a -> Either a b
Left (String -> Either String SyncatDef)
-> String -> Either String SyncatDef
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"expecting syntactic category definition:\n"
  , String
"  (<SyncatName> <production>… )\n"
  , String
"got:\n:"
  , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> Sexpr String -> String
forall a. (a -> String) -> Sexpr a -> String
Stupid.print String -> String
forall a. a -> a
id Sexpr String
other
  ]

parseProd :: Sexpr String -> Either String ProdDef
parseProd :: Sexpr String -> Either String ProdDef
parseProd (Combo String
"(" (Atom String
prodStr:[Sexpr String]
subtermExprs))
  | Just String
prodName <- String -> Maybe String
fromUpname String
prodStr = do
    [SubtermDef]
subterms <- Sexpr String -> Either String SubtermDef
parseSubterm (Sexpr String -> Either String SubtermDef)
-> [Sexpr String] -> Either String [SubtermDef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [Sexpr String]
subtermExprs
    ProdDef -> Either String ProdDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProdDef -> Either String ProdDef)
-> ProdDef -> Either String ProdDef
forall a b. (a -> b) -> a -> b
$ String -> [SubtermDef] -> ProdDef
ProdDef String
prodName [SubtermDef]
subterms
parseProd Sexpr String
other = String -> Either String ProdDef
forall a b. a -> Either a b
Left (String -> Either String ProdDef)
-> String -> Either String ProdDef
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"expecting a production definition:\n"
  , String
"  (<ProductionName> <subterm>… )\n"
  , String
"got:\n"
  , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> Sexpr String -> String
forall a. (a -> String) -> Sexpr a -> String
Stupid.print String -> String
forall a. a -> a
id Sexpr String
other
  ]

parseSubterm :: Sexpr String -> Either String SubtermDef
parseSubterm :: Sexpr String -> Either String SubtermDef
parseSubterm (Combo String
"{" [Atom String
fieldStr, Sexpr String
typeExpr])
  | Just String
fieldName <- String -> Maybe String
fromLowername String
fieldStr = do
    TypeDesc
typeDesc <- Sexpr String -> Either String TypeDesc
parseType Sexpr String
typeExpr
    SubtermDef -> Either String SubtermDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SubtermDef -> Either String SubtermDef)
-> SubtermDef -> Either String SubtermDef
forall a b. (a -> b) -> a -> b
$ Maybe String -> TypeDesc -> SubtermDef
SubtermDef (String -> Maybe String
forall a. a -> Maybe a
Just String
fieldName) TypeDesc
typeDesc
parseSubterm Sexpr String
typeEexpr = case Sexpr String -> Either String TypeDesc
parseType Sexpr String
typeEexpr of
  Right TypeDesc
typeDesc -> SubtermDef -> Either String SubtermDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SubtermDef -> Either String SubtermDef)
-> SubtermDef -> Either String SubtermDef
forall a b. (a -> b) -> a -> b
$ Maybe String -> TypeDesc -> SubtermDef
SubtermDef Maybe String
forall a. Maybe a
Nothing TypeDesc
typeDesc
  Left String
errTy -> String -> Either String SubtermDef
forall a b. a -> Either a b
Left (String -> Either String SubtermDef)
-> String -> Either String SubtermDef
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ String
"expecting a subterm definition:\n"
    , String
"     {<fieldName> <type>}\n"
    , String
"  or <type>\n"
    , String
"but parsing <type> failed:\n"
    , [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"  "String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
errTy
    ]

parseType :: Sexpr String -> Either String TypeDesc
parseType :: Sexpr String -> Either String TypeDesc
parseType (Atom String
str)
  | Char
'$':String
str' <- String
str
  , Just String
mutrec <- String -> Maybe String
fromUpname String
str'
    = TypeDesc -> Either String TypeDesc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc -> Either String TypeDesc)
-> TypeDesc -> Either String TypeDesc
forall a b. (a -> b) -> a -> b
$ String -> TypeDesc
RecursiveType String
mutrec
  | Just String
tyvar <- String -> Maybe String
fromLowername String
str
    = TypeDesc -> Either String TypeDesc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc -> Either String TypeDesc)
-> TypeDesc -> Either String TypeDesc
forall a b. (a -> b) -> a -> b
$ Name -> TypeDesc
VarType (String -> Name
TH.mkName String
tyvar)
  | Just String
ctorName <- String -> Maybe String
fromUpdotname String
str = TypeDesc -> Either String TypeDesc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc -> Either String TypeDesc)
-> TypeDesc -> Either String TypeDesc
forall a b. (a -> b) -> a -> b
$ Name -> [TypeDesc] -> TypeDesc
CtorType (String -> Name
TH.mkName String
ctorName) []
parseType (Combo String
"(" [Sexpr String]
subexprs)
  | Just (Sexpr String
innerExpr, TypeDesc -> TypeDesc
modifier) <- [Sexpr String] -> Maybe (Sexpr String, TypeDesc -> TypeDesc)
fromShortcut [Sexpr String]
subexprs = do
      TypeDesc
innerType <- Sexpr String -> Either String TypeDesc
parseType Sexpr String
innerExpr
      TypeDesc -> Either String TypeDesc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc -> Either String TypeDesc)
-> TypeDesc -> Either String TypeDesc
forall a b. (a -> b) -> a -> b
$ TypeDesc -> TypeDesc
modifier TypeDesc
innerType
  | Just (String
tycon, [Sexpr String]
argExprs) <- [Sexpr String] -> Maybe (String, [Sexpr String])
fromTycon [Sexpr String]
subexprs = do
    [TypeDesc]
args <- Sexpr String -> Either String TypeDesc
parseType (Sexpr String -> Either String TypeDesc)
-> [Sexpr String] -> Either String [TypeDesc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [Sexpr String]
argExprs
    TypeDesc -> Either String TypeDesc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc -> Either String TypeDesc)
-> TypeDesc -> Either String TypeDesc
forall a b. (a -> b) -> a -> b
$ Name -> [TypeDesc] -> TypeDesc
CtorType (String -> Name
TH.mkName String
tycon) [TypeDesc]
args
parseType (Combo String
"[" [Sexpr String]
subexprs)
  | Just (Sexpr String
lhsExpr, Sexpr String
rhsExpr) <- [Sexpr String] -> Maybe (Sexpr String, Sexpr String)
fromMapType [Sexpr String]
subexprs = do
    TypeDesc
lhs <- Sexpr String -> Either String TypeDesc
parseType Sexpr String
lhsExpr
    TypeDesc
rhs <- Sexpr String -> Either String TypeDesc
parseType Sexpr String
rhsExpr
    TypeDesc -> Either String TypeDesc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc -> Either String TypeDesc)
-> TypeDesc -> Either String TypeDesc
forall a b. (a -> b) -> a -> b
$ TypeDesc -> TypeDesc
ListType (TypeDesc -> TypeDesc -> [TypeDesc] -> TypeDesc
TupleType TypeDesc
lhs TypeDesc
rhs [])
parseType (Combo String
"{" [Sexpr String]
subexprs)
  | Just (Sexpr String
lhsExpr, Sexpr String
rhsExpr) <- [Sexpr String] -> Maybe (Sexpr String, Sexpr String)
fromMapType [Sexpr String]
subexprs = do
    TypeDesc
lhs <- Sexpr String -> Either String TypeDesc
parseType Sexpr String
lhsExpr
    TypeDesc
rhs <- Sexpr String -> Either String TypeDesc
parseType Sexpr String
rhsExpr
    TypeDesc -> Either String TypeDesc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc -> Either String TypeDesc)
-> TypeDesc -> Either String TypeDesc
forall a b. (a -> b) -> a -> b
$ TypeDesc -> TypeDesc -> TypeDesc
MapType TypeDesc
lhs TypeDesc
rhs
  | Bool
otherwise = Sexpr String -> Either String TypeDesc
parseType (Sexpr String -> Either String TypeDesc)
-> [Sexpr String] -> Either String [TypeDesc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [Sexpr String]
subexprs Either String [TypeDesc]
-> ([TypeDesc] -> Either String TypeDesc) -> Either String TypeDesc
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    (TypeDesc
t1:TypeDesc
t2:[TypeDesc]
ts) -> TypeDesc -> Either String TypeDesc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc -> Either String TypeDesc)
-> TypeDesc -> Either String TypeDesc
forall a b. (a -> b) -> a -> b
$ TypeDesc -> TypeDesc -> [TypeDesc] -> TypeDesc
TupleType TypeDesc
t1 TypeDesc
t2 [TypeDesc]
ts
    [TypeDesc]
_ -> String -> Either String TypeDesc
forall a b. a -> Either a b
Left (String -> Either String TypeDesc)
-> String -> Either String TypeDesc
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"expecting two or more types as part of a tuple, got:\n"
      , [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> Sexpr String -> String
forall a. (a -> String) -> Sexpr a -> String
Stupid.print String -> String
forall a. a -> a
id (Sexpr String -> String) -> [Sexpr String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Sexpr String]
subexprs
      ]
parseType Sexpr String
other = String -> Either String TypeDesc
forall a b. a -> Either a b
Left (String -> Either String TypeDesc)
-> String -> Either String TypeDesc
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"expecting type description, one of:\n"
  , String
"  $<SyncatName>\n"
  , String
"  <typeParam>\n"
  , String
"  <TypeCtor>                # == ($<TypeCtor>)\n"
  , String
"  (<TypeCtor> <type>… )\n"
  , String
"  (<type> <* | + | ?>… )    # list, nonempty list, and maybe\n"
  , String
"  {<type> <type> <type>… }  # tuple\n"
  , String
"  [ <type> :-> <type> ]     # association list\n"
  , String
"  { <type> :-> <type> }     # ord map\n"
  , String
"got:\n"
  , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> Sexpr String -> String
forall a. (a -> String) -> Sexpr a -> String
Stupid.print String -> String
forall a. a -> a
id Sexpr String
other
  ]

---------------------------------
------ Language Extensions ------
---------------------------------

parseLangMod :: Maybe String -> Sexpr String -> Sexpr String -> [String] -> [Sexpr String] -> Either String LangMod
parseLangMod :: Maybe String
-> Sexpr String
-> Sexpr String
-> [String]
-> [Sexpr String]
-> Either String LangMod
parseLangMod Maybe String
originalModProgram Sexpr String
baseExpr Sexpr String
newExpr [String]
newParamReqs [Sexpr String]
modExprs = do
  String
baseLangReq <- Sexpr String -> Either String String
parseBaseLangName Sexpr String
baseExpr
  String
newLangReq <- Sexpr String -> Either String String
parseLangName Sexpr String
newExpr
  [[SyncatMod]]
modss <- Sexpr String -> Either String [SyncatMod]
parseSyncatMod (Sexpr String -> Either String [SyncatMod])
-> [Sexpr String] -> Either String [[SyncatMod]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [Sexpr String]
modExprs
  LangMod -> Either String LangMod
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LangMod -> Either String LangMod)
-> LangMod -> Either String LangMod
forall a b. (a -> b) -> a -> b
$ LangMod
    { String
baseLangReq :: String
baseLangReq :: String
baseLangReq
    , String
newLangReq :: String
newLangReq :: String
newLangReq
    , [String]
newParamReqs :: [String]
newParamReqs :: [String]
newParamReqs
    , syncatMods :: [SyncatMod]
syncatMods = [[SyncatMod]] -> [SyncatMod]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[SyncatMod]]
modss
    , Maybe String
originalModProgram :: Maybe String
originalModProgram :: Maybe String
originalModProgram
    }

parseBaseLangName :: Sexpr String -> Either String String
parseBaseLangName :: Sexpr String -> Either String String
parseBaseLangName (Atom String
str) | Just String
str' <- String -> Maybe String
fromUpdotname String
str = String -> Either String String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
str'
parseBaseLangName Sexpr String
_ = String -> Either String String
forall a b. a -> Either a b
Left String
"base language name must be a non-empty list of dot-separated UpCase alphanumeric symbol"

parseSyncatMod :: Sexpr String -> Either String [SyncatMod]
parseSyncatMod :: Sexpr String -> Either String [SyncatMod]
parseSyncatMod (Combo String
"(" (Atom String
"+":[Sexpr String]
syncatExprs)) = do
  ((SyncatDef -> SyncatMod)
-> Either String SyncatDef -> Either String SyncatMod
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SyncatDef -> SyncatMod
AddSyncat (Either String SyncatDef -> Either String SyncatMod)
-> (Sexpr String -> Either String SyncatDef)
-> Sexpr String
-> Either String SyncatMod
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sexpr String -> Either String SyncatDef
parseSyncat) (Sexpr String -> Either String SyncatMod)
-> [Sexpr String] -> Either String [SyncatMod]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [Sexpr String]
syncatExprs
parseSyncatMod (Combo String
"(" (Atom String
"-":[Sexpr String]
syncatExprs)) =
  [Sexpr String]
-> (Sexpr String -> Either String SyncatMod)
-> Either String [SyncatMod]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Sexpr String]
syncatExprs ((Sexpr String -> Either String SyncatMod)
 -> Either String [SyncatMod])
-> (Sexpr String -> Either String SyncatMod)
-> Either String [SyncatMod]
forall a b. (a -> b) -> a -> b
$ \case
    (Atom String
syncatStr) | Just String
sName <- String -> Maybe String
fromUpname String
syncatStr -> SyncatMod -> Either String SyncatMod
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SyncatMod -> Either String SyncatMod)
-> SyncatMod -> Either String SyncatMod
forall a b. (a -> b) -> a -> b
$ String -> SyncatMod
DelSyncat String
sName
    Sexpr String
other -> String -> Either String SyncatMod
forall a b. a -> Either a b
Left (String -> Either String SyncatMod)
-> String -> Either String SyncatMod
forall a b. (a -> b) -> a -> b
$ String
"expecting the name of a syntactic category, got:\n  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> Sexpr String -> String
forall a. (a -> String) -> Sexpr a -> String
Stupid.print String -> String
forall a. a -> a
id Sexpr String
other
parseSyncatMod (Combo String
"(" (Atom String
"*":[Sexpr String]
syncatExprs)) =
  [Sexpr String]
-> (Sexpr String -> Either String SyncatMod)
-> Either String [SyncatMod]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Sexpr String]
syncatExprs ((Sexpr String -> Either String SyncatMod)
 -> Either String [SyncatMod])
-> (Sexpr String -> Either String SyncatMod)
-> Either String [SyncatMod]
forall a b. (a -> b) -> a -> b
$ \case
    (Combo String
"(" (Atom String
sStr:[Sexpr String]
pModExprs))
      | Just String
sName <- String -> Maybe String
fromUpname String
sStr -> do
        [ProdMod]
pMods <- Sexpr String -> Either String ProdMod
parseProdMod (Sexpr String -> Either String ProdMod)
-> [Sexpr String] -> Either String [ProdMod]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [Sexpr String]
pModExprs
        SyncatMod -> Either String SyncatMod
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SyncatMod -> Either String SyncatMod)
-> SyncatMod -> Either String SyncatMod
forall a b. (a -> b) -> a -> b
$ String -> [ProdMod] -> SyncatMod
ModProds String
sName [ProdMod]
pMods
    Sexpr String
other -> String -> Either String SyncatMod
forall a b. a -> Either a b
Left (String -> Either String SyncatMod)
-> String -> Either String SyncatMod
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"expecting syntactic category modifier:\n"
      , String
"  (<SyncatName> <ctor mods>… )\n"
      , String
"got:\n"
      , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> Sexpr String -> String
forall a. (a -> String) -> Sexpr a -> String
Stupid.print String -> String
forall a. a -> a
id Sexpr String
other
      ]
parseSyncatMod Sexpr String
other = String -> Either String [SyncatMod]
forall a b. a -> Either a b
Left (String -> Either String [SyncatMod])
-> String -> Either String [SyncatMod]
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"expecting syntactic category modifier batch:\n"
  , String
"  (+ <syncat modifier>… )\n"
  , String
"  (* <syncat modifier>… )\n"
  , String
"  (- <syncat modifier>… )\n"
  , String
"got:\n"
  , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> Sexpr String -> String
forall a. (a -> String) -> Sexpr a -> String
Stupid.print String -> String
forall a. a -> a
id Sexpr String
other
  ]

parseProdMod :: Sexpr String -> Either String ProdMod
parseProdMod :: Sexpr String -> Either String ProdMod
parseProdMod (Combo String
"(" (Atom String
"+":Atom String
prodStr:[Sexpr String]
subtermExprs))
  | Just String
prodName <- String -> Maybe String
fromUpname String
prodStr = do
    [SubtermDef]
subterms <- Sexpr String -> Either String SubtermDef
parseSubterm (Sexpr String -> Either String SubtermDef)
-> [Sexpr String] -> Either String [SubtermDef]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` [Sexpr String]
subtermExprs
    ProdMod -> Either String ProdMod
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProdMod -> Either String ProdMod)
-> ProdMod -> Either String ProdMod
forall a b. (a -> b) -> a -> b
$ ProdDef -> ProdMod
AddProd (ProdDef -> ProdMod) -> ProdDef -> ProdMod
forall a b. (a -> b) -> a -> b
$ String -> [SubtermDef] -> ProdDef
ProdDef String
prodName [SubtermDef]
subterms
parseProdMod (Combo String
"(" [Atom String
"-", Atom String
prodStr])
  | Just String
prodName <- String -> Maybe String
fromUpname String
prodStr = ProdMod -> Either String ProdMod
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProdMod -> Either String ProdMod)
-> ProdMod -> Either String ProdMod
forall a b. (a -> b) -> a -> b
$ String -> ProdMod
DelProd String
prodName
parseProdMod Sexpr String
other = String -> Either String ProdMod
forall a b. a -> Either a b
Left (String -> Either String ProdMod)
-> String -> Either String ProdMod
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"expecting a contructor modifier:\n"
  , String
"  (+ <CtorName> <subterm>… )\n"
  , String
"  (- <CtorName>)\n"
  , String
"got:\n"
  , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> Sexpr String -> String
forall a. (a -> String) -> Sexpr a -> String
Stupid.print String -> String
forall a. a -> a
id Sexpr String
other
  ]

-----------------------------------
------ Pattern Match Helpers ------
-----------------------------------

fromTycon :: [Sexpr String] -> Maybe (String, [Sexpr String])
fromTycon :: [Sexpr String] -> Maybe (String, [Sexpr String])
fromTycon (Atom String
tyconName : [Sexpr String]
argExprs) = do
  String
tycon <- String -> Maybe String
fromUpdotname String
tyconName
  (String, [Sexpr String]) -> Maybe (String, [Sexpr String])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
tycon, [Sexpr String]
argExprs)
fromTycon [Sexpr String]
_ = Maybe (String, [Sexpr String])
forall a. Maybe a
Nothing

fromShortcut :: [Sexpr String] -> Maybe (Sexpr String, TypeDesc -> TypeDesc)
fromShortcut :: [Sexpr String] -> Maybe (Sexpr String, TypeDesc -> TypeDesc)
fromShortcut [Sexpr String]
exprs0 = case [Sexpr String] -> [Sexpr String]
forall a. [a] -> [a]
reverse [Sexpr String]
exprs0 of
  yes :: [Sexpr String]
yes@(Atom String
sym:[Sexpr String]
_)
    | String
sym String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((String, TypeDesc -> TypeDesc) -> String
forall a b. (a, b) -> a
fst ((String, TypeDesc -> TypeDesc) -> String)
-> [(String, TypeDesc -> TypeDesc)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, TypeDesc -> TypeDesc)]
shortcuts) -> [Sexpr String] -> Maybe (Sexpr String, TypeDesc -> TypeDesc)
forall {m :: * -> *}.
Monad m =>
[Sexpr String] -> m (Sexpr String, TypeDesc -> TypeDesc)
loop [Sexpr String]
yes
  [Sexpr String]
_ -> Maybe (Sexpr String, TypeDesc -> TypeDesc)
forall a. Maybe a
Nothing
  where
  loop :: [Sexpr String] -> m (Sexpr String, TypeDesc -> TypeDesc)
loop (Atom String
sym : [Sexpr String]
rest)
    | Just TypeDesc -> TypeDesc
f' <- String
-> [(String, TypeDesc -> TypeDesc)] -> Maybe (TypeDesc -> TypeDesc)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
sym [(String, TypeDesc -> TypeDesc)]
shortcuts = do
      (Sexpr String
inner, TypeDesc -> TypeDesc
f) <- [Sexpr String] -> m (Sexpr String, TypeDesc -> TypeDesc)
loop [Sexpr String]
rest
      (Sexpr String, TypeDesc -> TypeDesc)
-> m (Sexpr String, TypeDesc -> TypeDesc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sexpr String
inner, TypeDesc -> TypeDesc
f' (TypeDesc -> TypeDesc)
-> (TypeDesc -> TypeDesc) -> TypeDesc -> TypeDesc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeDesc -> TypeDesc
f)
  loop [Sexpr String
inner] = (Sexpr String, TypeDesc -> TypeDesc)
-> m (Sexpr String, TypeDesc -> TypeDesc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sexpr String
inner, TypeDesc -> TypeDesc
forall a. a -> a
id) -- NOTE this is a separate base case b/c we don't want to wrap a metavar in parens
  loop inners :: [Sexpr String]
inners@(Sexpr String
_:[Sexpr String]
_) = (Sexpr String, TypeDesc -> TypeDesc)
-> m (Sexpr String, TypeDesc -> TypeDesc)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [Sexpr String] -> Sexpr String
forall a. String -> [Sexpr a] -> Sexpr a
Combo String
"(" ([Sexpr String] -> [Sexpr String]
forall a. [a] -> [a]
reverse [Sexpr String]
inners), TypeDesc -> TypeDesc
forall a. a -> a
id)
  loop [] = String -> m (Sexpr String, TypeDesc -> TypeDesc)
forall a. String -> a
errorWithoutStackTrace String
"internal nanopass error in fromShortcut"
  shortcuts :: [(String, TypeDesc -> TypeDesc)]
shortcuts =
    [ (String
"*", TypeDesc -> TypeDesc
ListType)
    , (String
"+", TypeDesc -> TypeDesc
NonEmptyType)
    , (String
"?", TypeDesc -> TypeDesc
MaybeType)
    ]

fromMapType :: [Sexpr String] -> Maybe (Sexpr String, Sexpr String)
fromMapType :: [Sexpr String] -> Maybe (Sexpr String, Sexpr String)
fromMapType [Sexpr String]
exprs = case (Sexpr String -> Bool)
-> [Sexpr String] -> ([Sexpr String], [Sexpr String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Sexpr String -> Bool
isArrow [Sexpr String]
exprs of
  ([], [Sexpr String]
_) -> Maybe (Sexpr String, Sexpr String)
forall a. Maybe a
Nothing
  ([Sexpr String]
_, []) -> Maybe (Sexpr String, Sexpr String)
forall a. Maybe a
Nothing
  ([Sexpr String]
_, [Sexpr String
_]) -> Maybe (Sexpr String, Sexpr String)
forall a. Maybe a
Nothing
  ([Sexpr String]
lhs, Sexpr String
_:[Sexpr String]
rhs) ->
    let l :: Sexpr String
l = case [Sexpr String]
lhs of { [Sexpr String
it] -> Sexpr String
it ; [Sexpr String]
_ -> String -> [Sexpr String] -> Sexpr String
forall a. String -> [Sexpr a] -> Sexpr a
Combo String
"(" [Sexpr String]
lhs }
        r :: Sexpr String
r = case [Sexpr String]
rhs of { [Sexpr String
it] -> Sexpr String
it ; [Sexpr String]
_ -> String -> [Sexpr String] -> Sexpr String
forall a. String -> [Sexpr a] -> Sexpr a
Combo String
"(" [Sexpr String]
rhs }
     in (Sexpr String, Sexpr String) -> Maybe (Sexpr String, Sexpr String)
forall a. a -> Maybe a
Just (Sexpr String
l, Sexpr String
r)
  where
  isArrow :: Sexpr String -> Bool
isArrow (Atom String
":->") = Bool
True
  isArrow Sexpr String
_ = Bool
False

fromUpdotname :: String -> Maybe String
fromUpdotname :: String -> Maybe String
fromUpdotname String
inp0 = String -> Maybe String
loop String
inp0
  where
  loop :: String -> Maybe String
loop String
inp = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') String
inp of
    ([], String
_) -> Maybe String
forall a. Maybe a
Nothing -- no leading dot (or empty string)
    (String
_, String
".") -> Maybe String
forall a. Maybe a
Nothing -- no trailing dot
    (String
_, []) -> String -> Maybe String
forall a. a -> Maybe a
Just String
inp0 -- no more dots
    (String
_, Char
_:String
rest) -> String -> Maybe String
loop String
rest


fromUpname :: String -> Maybe String
fromUpname :: String -> Maybe String
fromUpname (Char
c:String
cs) | Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAlphaNumderscore String
cs = String -> Maybe String
forall a. a -> Maybe a
Just (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs)
fromUpname String
_ = Maybe String
forall a. Maybe a
Nothing

fromLowername :: String -> Maybe String
fromLowername :: String -> Maybe String
fromLowername (Char
c:String
cs) | Char -> Bool
isLower Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isAlphaNumderscore String
cs = String -> Maybe String
forall a. a -> Maybe a
Just (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs)
fromLowername String
_ = Maybe String
forall a. Maybe a
Nothing

isAlphaNumderscore :: Char -> Bool
isAlphaNumderscore :: Char -> Bool
isAlphaNumderscore Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'