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

module Nanopass.Internal.Validate
  ( validateLanguage
  , validateParams
  , validateNonterm
  , validateProd
  , validateType
  ) where

import Nanopass.Internal.Representation

import Control.Monad (forM,when)
import Data.Functor ((<&>))
import Data.List (nub, (\\))
import Data.Map (Map)
import Data.Set (Set)
import Nanopass.Internal.Error (Error(..))

import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Language.Haskell.TH as TH

validateLanguage :: Language 'Unvalidated UpName -> Either Error (Language 'Valid UpName)
validateLanguage :: Language 'Unvalidated UpName
-> Either Error (Language 'Valid UpName)
validateLanguage Language 'Unvalidated UpName
lang = do
  [Name 'Valid LowName]
langParams <- [Name 'Unvalidated LowName] -> Either Error [Name 'Valid LowName]
validateParams Language 'Unvalidated UpName
lang.langInfo.langParams
  let tvs :: Map LowName (Name 'Valid LowName)
tvs = [(LowName, Name 'Valid LowName)]
-> Map LowName (Name 'Valid LowName)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(LowName, Name 'Valid LowName)]
 -> Map LowName (Name 'Valid LowName))
-> [(LowName, Name 'Valid LowName)]
-> Map LowName (Name 'Valid LowName)
forall a b. (a -> b) -> a -> b
$ [Name 'Valid LowName]
langParams [Name 'Valid LowName]
-> (Name 'Valid LowName -> (LowName, Name 'Valid LowName))
-> [(LowName, Name 'Valid LowName)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Name 'Valid LowName
n -> (Name 'Valid LowName
n.name, Name 'Valid LowName
n)
      nts :: Set UpName
nts = [UpName] -> Set UpName
forall a. Ord a => [a] -> Set a
Set.fromList ([UpName] -> Set UpName) -> [UpName] -> Set UpName
forall a b. (a -> b) -> a -> b
$ Map UpName (Nonterm 'Unvalidated) -> [UpName]
forall k a. Map k a -> [k]
Map.keys Language 'Unvalidated UpName
lang.langInfo.nonterms
  Map UpName (Nonterm 'Valid)
nonterms <- Set UpName
-> Map LowName (Name 'Valid LowName)
-> Nonterm 'Unvalidated
-> Either Error (Nonterm 'Valid)
forall (v :: Validate).
Set UpName
-> Map LowName (Name 'Valid LowName)
-> Nonterm v
-> Either Error (Nonterm 'Valid)
validateNonterm Set UpName
nts Map LowName (Name 'Valid LowName)
tvs (Nonterm 'Unvalidated -> Either Error (Nonterm 'Valid))
-> Map UpName (Nonterm 'Unvalidated)
-> Either Error (Map UpName (Nonterm 'Valid))
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) -> Map UpName a -> m (Map UpName b)
`mapM` Language 'Unvalidated UpName
lang.langInfo.nonterms
  Language 'Valid UpName -> Either Error (Language 'Valid UpName)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Language
    { $sel:langName:Language :: Name 'Valid UpName
langName = UpName -> Name -> Name 'Valid UpName
forall n. n -> Name -> Name 'Valid n
ValidName Language 'Unvalidated UpName
lang.langName.name (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ UpName -> String
fromUpName Language 'Unvalidated UpName
lang.langName.name)
    , $sel:langInfo:Language :: LanguageInfo 'Valid
langInfo = LanguageInfo
      { [Name 'Valid LowName]
langParams :: [Name 'Valid LowName]
$sel:langParams:LanguageInfo :: [Name 'Valid LowName]
langParams
      , Map UpName (Nonterm 'Valid)
nonterms :: Map UpName (Nonterm 'Valid)
$sel:nonterms:LanguageInfo :: Map UpName (Nonterm 'Valid)
nonterms
      , $sel:originalProgram:LanguageInfo :: Maybe String
originalProgram = Language 'Unvalidated UpName
lang.langInfo.originalProgram
      , $sel:baseDefdLang:LanguageInfo :: Maybe (Language 'Valid UpDotName)
baseDefdLang = Language 'Unvalidated UpName
lang.langInfo.baseDefdLang
      }
    }

validateParams :: [Name 'Unvalidated LowName] -> Either Error [Name 'Valid LowName]
validateParams :: [Name 'Unvalidated LowName] -> Either Error [Name 'Valid LowName]
validateParams [Name 'Unvalidated LowName]
tvs = do
  let duplicates :: [Name 'Unvalidated LowName]
duplicates = [Name 'Unvalidated LowName]
tvs [Name 'Unvalidated LowName]
-> [Name 'Unvalidated LowName] -> [Name 'Unvalidated LowName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Name 'Unvalidated LowName] -> [Name 'Unvalidated LowName]
forall a. Eq a => [a] -> [a]
nub [Name 'Unvalidated LowName]
tvs
  Bool -> Either Error () -> Either Error ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Name 'Unvalidated LowName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name 'Unvalidated LowName]
duplicates) (Either Error () -> Either Error ())
-> Either Error () -> Either Error ()
forall a b. (a -> b) -> a -> b
$ Error -> Either Error ()
forall a b. a -> Either a b
Left (Error -> Either Error ()) -> Error -> Either Error ()
forall a b. (a -> b) -> a -> b
$ [LowName] -> Error
DuplicateLanguageParams ([Name 'Unvalidated LowName]
duplicates [Name 'Unvalidated LowName]
-> (Name 'Unvalidated LowName -> LowName) -> [LowName]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (.name))
  [Name 'Unvalidated LowName]
-> (Name 'Unvalidated LowName
    -> Either Error (Name 'Valid LowName))
-> Either Error [Name 'Valid LowName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Name 'Unvalidated LowName]
tvs ((Name 'Unvalidated LowName -> Either Error (Name 'Valid LowName))
 -> Either Error [Name 'Valid LowName])
-> (Name 'Unvalidated LowName
    -> Either Error (Name 'Valid LowName))
-> Either Error [Name 'Valid LowName]
forall a b. (a -> b) -> a -> b
$ \Name 'Unvalidated LowName
n -> Name 'Valid LowName -> Either Error (Name 'Valid LowName)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name 'Valid LowName -> Either Error (Name 'Valid LowName))
-> Name 'Valid LowName -> Either Error (Name 'Valid LowName)
forall a b. (a -> b) -> a -> b
$ LowName -> Name -> Name 'Valid LowName
forall n. n -> Name -> Name 'Valid n
ValidName Name 'Unvalidated LowName
n.name (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ LowName -> String
fromLowName Name 'Unvalidated LowName
n.name)

validateNonterm :: Set UpName -- ^ known non-terminals
                -> Map LowName (Name 'Valid LowName) -- ^ known type variables
                -> Nonterm v
                -> Either Error (Nonterm 'Valid)
validateNonterm :: forall (v :: Validate).
Set UpName
-> Map LowName (Name 'Valid LowName)
-> Nonterm v
-> Either Error (Nonterm 'Valid)
validateNonterm Set UpName
nts Map LowName (Name 'Valid LowName)
tvs Nonterm v
nt = do
  let nontermName :: Name 'Valid UpName
nontermName = UpName -> Name -> Name 'Valid UpName
forall n. n -> Name -> Name 'Valid n
ValidName Nonterm v
nt.nontermName.name (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ UpName -> String
fromUpName Nonterm v
nt.nontermName.name)
  Map UpName (Production 'Valid)
productions <- Set UpName
-> Map LowName (Name 'Valid LowName)
-> Production v
-> Either Error (Production 'Valid)
forall (v :: Validate).
Set UpName
-> Map LowName (Name 'Valid LowName)
-> Production v
-> Either Error (Production 'Valid)
validateProd Set UpName
nts Map LowName (Name 'Valid LowName)
tvs (Production v -> Either Error (Production 'Valid))
-> Map UpName (Production v)
-> Either Error (Map UpName (Production 'Valid))
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) -> Map UpName a -> m (Map UpName b)
`mapM` Nonterm v
nt.productions
  Nonterm 'Valid -> Either Error (Nonterm 'Valid)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nonterm
    { Name 'Valid UpName
nontermName :: Name 'Valid UpName
$sel:nontermName:Nonterm :: Name 'Valid UpName
nontermName
    , Map UpName (Production 'Valid)
productions :: Map UpName (Production 'Valid)
$sel:productions:Nonterm :: Map UpName (Production 'Valid)
productions
    }

validateProd :: Set UpName -- ^ known non-terminals
             -> Map LowName (Name 'Valid LowName) -- ^ known type variables
             -> Production v
             -> Either Error (Production 'Valid)
validateProd :: forall (v :: Validate).
Set UpName
-> Map LowName (Name 'Valid LowName)
-> Production v
-> Either Error (Production 'Valid)
validateProd Set UpName
nts Map LowName (Name 'Valid LowName)
tvs Production v
prod = do
  let prodName :: Name 'Valid UpName
prodName = UpName -> Name -> Name 'Valid UpName
forall n. n -> Name -> Name 'Valid n
ValidName Production v
prod.prodName.name (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ UpName -> String
fromUpName Production v
prod.prodName.name)
  [TypeDesc 'Valid]
subterms <- Set UpName
-> Map LowName (Name 'Valid LowName)
-> TypeDesc v
-> Either Error (TypeDesc 'Valid)
forall (v :: Validate).
Set UpName
-> Map LowName (Name 'Valid LowName)
-> TypeDesc v
-> Either Error (TypeDesc 'Valid)
validateType Set UpName
nts Map LowName (Name 'Valid LowName)
tvs (TypeDesc v -> Either Error (TypeDesc 'Valid))
-> [TypeDesc v] -> Either Error [TypeDesc 'Valid]
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` Production v
prod.subterms
  Production 'Valid -> Either Error (Production 'Valid)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Production
    { Name 'Valid UpName
prodName :: Name 'Valid UpName
$sel:prodName:Production :: Name 'Valid UpName
prodName
    , [TypeDesc 'Valid]
subterms :: [TypeDesc 'Valid]
$sel:subterms:Production :: [TypeDesc 'Valid]
subterms
    }

validateType :: Set UpName -- ^ known non-terminals
             -> Map LowName (Name 'Valid LowName) -- ^ known type variables
             -> TypeDesc v
             -> Either Error (TypeDesc 'Valid)
validateType :: forall (v :: Validate).
Set UpName
-> Map LowName (Name 'Valid LowName)
-> TypeDesc v
-> Either Error (TypeDesc 'Valid)
validateType Set UpName
nts Map LowName (Name 'Valid LowName)
tvs = \case
  RecursiveType UpName
n -> case UpName -> Set UpName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member UpName
n Set UpName
nts of
    Bool
True -> TypeDesc 'Valid -> Either Error (TypeDesc 'Valid)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc 'Valid -> Either Error (TypeDesc 'Valid))
-> TypeDesc 'Valid -> Either Error (TypeDesc 'Valid)
forall a b. (a -> b) -> a -> b
$ UpName -> TypeDesc 'Valid
forall (v :: Validate). UpName -> TypeDesc v
RecursiveType UpName
n
    Bool
False -> Error -> Either Error (TypeDesc 'Valid)
forall a b. a -> Either a b
Left (Error -> Either Error (TypeDesc 'Valid))
-> Error -> Either Error (TypeDesc 'Valid)
forall a b. (a -> b) -> a -> b
$ UpName -> Error
UnrecognizedNonterm UpName
n
  VarType Name v LowName
n -> case LowName
-> Map LowName (Name 'Valid LowName) -> Maybe (Name 'Valid LowName)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name v LowName
n.name Map LowName (Name 'Valid LowName)
tvs of
    Just Name 'Valid LowName
validName -> TypeDesc 'Valid -> Either Error (TypeDesc 'Valid)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc 'Valid -> Either Error (TypeDesc 'Valid))
-> TypeDesc 'Valid -> Either Error (TypeDesc 'Valid)
forall a b. (a -> b) -> a -> b
$ Name 'Valid LowName -> TypeDesc 'Valid
forall (v :: Validate). Name v LowName -> TypeDesc v
VarType Name 'Valid LowName
validName
    Maybe (Name 'Valid LowName)
Nothing -> Error -> Either Error (TypeDesc 'Valid)
forall a b. a -> Either a b
Left (Error -> Either Error (TypeDesc 'Valid))
-> Error -> Either Error (TypeDesc 'Valid)
forall a b. (a -> b) -> a -> b
$ LowName -> Error
UnrecognizedTypeVariable Name v LowName
n.name
  CtorType Name v UpDotName
n [TypeDesc v]
ts
    | ([], UpName
n') <- UpDotName -> ([UpName], UpName)
splitUpDotName Name v UpDotName
n.name
    , UpName
n' UpName -> Set UpName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UpName
nts
    -> case [TypeDesc v]
ts of
      [] -> TypeDesc 'Valid -> Either Error (TypeDesc 'Valid)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDesc 'Valid -> Either Error (TypeDesc 'Valid))
-> TypeDesc 'Valid -> Either Error (TypeDesc 'Valid)
forall a b. (a -> b) -> a -> b
$ UpName -> TypeDesc 'Valid
forall (v :: Validate). UpName -> TypeDesc v
RecursiveType UpName
n'
      [TypeDesc v]
_ -> Error -> Either Error (TypeDesc 'Valid)
forall a b. a -> Either a b
Left (Error -> Either Error (TypeDesc 'Valid))
-> Error -> Either Error (TypeDesc 'Valid)
forall a b. (a -> b) -> a -> b
$ UpName -> Error
UnexpectedTypeApplicationstoRecursiveType UpName
n'
  CtorType (SourceName UpDotName
n) [TypeDesc v]
ts -> do
    let ctor :: Name 'Valid UpDotName
ctor = UpDotName -> Name -> Name 'Valid UpDotName
forall n. n -> Name -> Name 'Valid n
ValidName UpDotName
n (String -> Name
TH.mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ UpDotName -> String
fromUpDotName UpDotName
n)
    Name 'Valid UpDotName -> [TypeDesc 'Valid] -> TypeDesc 'Valid
forall (v :: Validate).
Name v UpDotName -> [TypeDesc v] -> TypeDesc v
CtorType Name 'Valid UpDotName
ctor ([TypeDesc 'Valid] -> TypeDesc 'Valid)
-> Either Error [TypeDesc 'Valid] -> Either Error (TypeDesc 'Valid)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeDesc v -> Either Error (TypeDesc 'Valid)
loop (TypeDesc v -> Either Error (TypeDesc 'Valid))
-> [TypeDesc v] -> Either Error [TypeDesc 'Valid]
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` [TypeDesc v]
ts
  CtorType ctor :: Name v UpDotName
ctor@(ValidName UpDotName
_ Name
_) [TypeDesc v]
ts -> do
    Name 'Valid UpDotName -> [TypeDesc 'Valid] -> TypeDesc 'Valid
forall (v :: Validate).
Name v UpDotName -> [TypeDesc v] -> TypeDesc v
CtorType Name v UpDotName
Name 'Valid UpDotName
ctor ([TypeDesc 'Valid] -> TypeDesc 'Valid)
-> Either Error [TypeDesc 'Valid] -> Either Error (TypeDesc 'Valid)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeDesc v -> Either Error (TypeDesc 'Valid)
loop (TypeDesc v -> Either Error (TypeDesc 'Valid))
-> [TypeDesc v] -> Either Error [TypeDesc 'Valid]
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` [TypeDesc v]
ts
  ListType TypeDesc v
t -> TypeDesc 'Valid -> TypeDesc 'Valid
forall (v :: Validate). TypeDesc v -> TypeDesc v
ListType (TypeDesc 'Valid -> TypeDesc 'Valid)
-> Either Error (TypeDesc 'Valid) -> Either Error (TypeDesc 'Valid)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeDesc v -> Either Error (TypeDesc 'Valid)
loop TypeDesc v
t
  MaybeType TypeDesc v
t -> TypeDesc 'Valid -> TypeDesc 'Valid
forall (v :: Validate). TypeDesc v -> TypeDesc v
MaybeType (TypeDesc 'Valid -> TypeDesc 'Valid)
-> Either Error (TypeDesc 'Valid) -> Either Error (TypeDesc 'Valid)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeDesc v -> Either Error (TypeDesc 'Valid)
loop TypeDesc v
t
  NonEmptyType TypeDesc v
t -> TypeDesc 'Valid -> TypeDesc 'Valid
forall (v :: Validate). TypeDesc v -> TypeDesc v
NonEmptyType (TypeDesc 'Valid -> TypeDesc 'Valid)
-> Either Error (TypeDesc 'Valid) -> Either Error (TypeDesc 'Valid)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeDesc v -> Either Error (TypeDesc 'Valid)
loop TypeDesc v
t
  TypeDesc v
UnitType -> TypeDesc 'Valid -> Either Error (TypeDesc 'Valid)
forall a. a -> Either Error a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDesc 'Valid
forall (v :: Validate). TypeDesc v
UnitType
  TupleType TypeDesc v
t1 TypeDesc v
t2 [TypeDesc v]
ts -> TypeDesc 'Valid
-> TypeDesc 'Valid -> [TypeDesc 'Valid] -> TypeDesc 'Valid
forall (v :: Validate).
TypeDesc v -> TypeDesc v -> [TypeDesc v] -> TypeDesc v
TupleType (TypeDesc 'Valid
 -> TypeDesc 'Valid -> [TypeDesc 'Valid] -> TypeDesc 'Valid)
-> Either Error (TypeDesc 'Valid)
-> Either
     Error (TypeDesc 'Valid -> [TypeDesc 'Valid] -> TypeDesc 'Valid)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeDesc v -> Either Error (TypeDesc 'Valid)
loop TypeDesc v
t1 Either
  Error (TypeDesc 'Valid -> [TypeDesc 'Valid] -> TypeDesc 'Valid)
-> Either Error (TypeDesc 'Valid)
-> Either Error ([TypeDesc 'Valid] -> TypeDesc 'Valid)
forall a b.
Either Error (a -> b) -> Either Error a -> Either Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeDesc v -> Either Error (TypeDesc 'Valid)
loop TypeDesc v
t2 Either Error ([TypeDesc 'Valid] -> TypeDesc 'Valid)
-> Either Error [TypeDesc 'Valid] -> Either Error (TypeDesc 'Valid)
forall a b.
Either Error (a -> b) -> Either Error a -> Either Error b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TypeDesc v -> Either Error (TypeDesc 'Valid)
loop (TypeDesc v -> Either Error (TypeDesc 'Valid))
-> [TypeDesc v] -> Either Error [TypeDesc 'Valid]
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` [TypeDesc v]
ts
  where loop :: TypeDesc v -> Either Error (TypeDesc 'Valid)
loop = Set UpName
-> Map LowName (Name 'Valid LowName)
-> TypeDesc v
-> Either Error (TypeDesc 'Valid)
forall (v :: Validate).
Set UpName
-> Map LowName (Name 'Valid LowName)
-> TypeDesc v
-> Either Error (TypeDesc 'Valid)
validateType Set UpName
nts Map LowName (Name 'Valid LowName)
tvs