Validate.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE TypeFamilies #-}

-- | Checks that Descript source is well-formed before it's interpreted.
-- If the source isn't well-formed, generates user-friendly problems.
module Descript.BasicInj.Process.Validate
  ( validateForRefactor
  , validate
  , validate_
  , validate'
  , validateForRefactorIn
  , validateIn
  , validateIn_
  , validateIn'
  ) where

import qualified Descript.BasicInj.Traverse.Term as T
import Descript.BasicInj.Traverse
import qualified Descript.BasicInj.Data.Value.In as In
import qualified Descript.BasicInj.Data.Value.Out as Out
import qualified Descript.BasicInj.Data.Type as RecordType (head)
import Descript.BasicInj.Data
import qualified Descript.Misc.Build.Process.Validate.Term as Term
import Descript.Misc
import Data.Semigroup as S
import Data.Monoid as M
import Data.List
import Core.Data.List
import Core.Data.List.Assoc
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import Core.Control.Monad.Trans
import Prelude hiding (head, mod)

newtype ValidateAll an = ValidateAll (AModule ())
newtype ValidateRecords an = ValidateRecords (RecordCtx ())
newtype ValidatePropPaths an = ValidatePropPaths (In.Value ())

instance (Semigroup an) => Fold (ValidateAll an) where
  type Res (ValidateAll an) = [Problem an]
  type FAnn (ValidateAll an) = an

  fonTerm T.Program (ValidateAll extra) prog
    = foldTerm T.Query (ValidateRecords recordCtx') (query prog)
    where recordCtx' = recordCtx_ M.<> recordCtx extra
          recordCtx_ = remAnns $ recordCtx $ amodule $ module' prog
  fonTerm T.AModule (ValidateAll extra) mod
    = foldTerm T.ReduceCtx (ValidateRecords recordCtx') (reduceCtx mod)
    where recordCtx' = recordCtx_ M.<> recordCtx extra
          recordCtx_ = remAnns $ recordCtx mod
  fonTerm T.ImportCtx (ValidateAll _) (ImportCtx _ _ idecls)
    = validateImportDeclsNoDups idecls
  fonTerm T.RecordCtx (ValidateAll extra) (RecordCtx _ decls)
    = validateRecordDeclsNoDups extraDecls decls
    where extraDecls = recordCtxDecls $ recordCtx extra
  fonTerm T.Reducer (ValidateAll _) (Reducer _ input' output')
    = foldTerm T.Output (ValidatePropPaths input_) output'
    where input_ = remAnns input'
  fonTerm T.GenRecord (ValidateAll _) (Record _ _ props)
    = validatePropsNoDups props
  fonTerm T.InjApp (ValidateAll _) injApp = validateInjAppExists injApp
  fonTerm _ _ _ = mempty

instance (Semigroup an) => Fold (ValidateRecords an) where
  type Res (ValidateRecords an) = [Problem an]
  type FAnn (ValidateRecords an) = an

  fonTerm T.GenRecord (ValidateRecords recordCtx') record
    = validateRecordConforms recordCtx' record
  fonTerm _ _ _ = mempty

instance (Semigroup an) => Fold (ValidatePropPaths an) where
  type Res (ValidatePropPaths an) = [Problem an]
  type FAnn (ValidatePropPaths an) = an

  fonTerm T.PropPath (ValidatePropPaths input') path
    = validatePathExists input' path
  fonTerm _ _ _ = mempty

-- | If the node is valid, returns an empty success.
-- Otherwise returns a refactor failure.
validateForRefactor :: (Monad u)
                    => DirtyDepd Source SrcAnn
                    -> RefactorResultT u ()
validateForRefactor = hoist . mapError RefactorValidateError . validate_

-- | If the source is valid, returns a success containing it.
-- Otherwise returns a failure containing all the problems.
validate :: (Ord an, Semigroup an)
         => DirtyDepd Source an
         -> Result [Problem an] (Depd Source an)
validate dx
  | null problems = Success $ mapDep dirtyVal dx
  | otherwise = Failure problems
  where problems = validate' dx

-- | If the source is valid, returns an empty success.
-- Otherwise returns a failure containing all the problems.
-- Useful in do notation.
validate_ :: (Ord an, Semigroup an)
          => DirtyDepd Source an
          -> Result [Problem an] ()
validate_ dx
  | null problems = Success ()
  | otherwise = Failure problems
  where problems = validate' dx

-- | Finds all problems within the source. If the source has no
-- problems, it's well formed and can be interpreted.
validate' :: (Ord an, Semigroup an)
          => DirtyDepd Source an
          -> [Problem an]
validate' (Depd (Dirty derrs extra) x) = dprobs ++ rprobs
  where dprobs = map ProblemDepFail derrs
        rprobs = validateIn' T.Source extra x

-- | If the node is valid, returns an empty success.
-- Otherwise returns a refactor failure.
validateForRefactorIn :: (Monad u)
                      => TTerm t
                      -> AModule ()
                      -> t SrcAnn
                      -> RefactorResultT u ()
validateForRefactorIn term extra
  = hoist . mapError RefactorValidateError . validateIn_ term extra

-- | If the node is valid, returns a success containing it.
-- Otherwise returns a failure containing all the problems.
-- Uses context (e.g. declared records) from the module.
validateIn :: (Ord an, Semigroup an)
           => TTerm t
           -> AModule ()
           -> t an
           -> Result [Problem an] (t an)
validateIn term extra x
  | null problems = Success x
  | otherwise = Failure problems
  where problems = validateIn' term extra x

-- | If the node is valid, returns an empty success.
-- Otherwise returns a failure containing all the problems.
-- Useful in do notation.
-- Uses context (e.g. declared records) from the module.
validateIn_ :: (Ord an, Semigroup an)
            => TTerm t
            -> AModule ()
            -> t an
            -> Result [Problem an] ()
validateIn_ term extra x
  | null problems = Success ()
  | otherwise = Failure problems
  where problems = validateIn' term extra x

-- | Finds all problems within the node. If the node has no
-- problems, it's well formed and can be interpreted.
-- Uses context (e.g. declared records) from the module.
validateIn' :: (Ord an, Semigroup an) => TTerm t -> AModule () -> t an -> [Problem an]
validateIn' term extra = sortOn getAnn . foldTerm term (ValidateAll extra)

validateImportDeclsNoDups :: (Semigroup an) => [ImportDecl an] -> [Problem an]
validateImportDeclsNoDups decls
  = concat $ zipWith validateImportDeclNoConflict otherDeclss decls
  where otherDeclss = inits $ map remAnns decls

validateRecordDeclsNoDups :: (Semigroup an) => [RecordDecl ()] -> [RecordDecl an] -> [Problem an]
validateRecordDeclsNoDups extraDecls decls
  = concat $ zipWith validateRecordDeclNoDup otherDeclss decls
  where otherDeclss = map (extraDecls ++) $ inits $ map remAnns decls

validatePropsNoDups :: (Semigroup an, FwdPrintable v, GenPropVal v)
                    => [GenProperty v an]
                    -> [Problem an]
validatePropsNoDups props
  = concat $ zipWith validatePropNoDup otherPropss props
  where otherPropss = inits $ map remAnns props

validateImportDeclNoConflict :: (Semigroup an) => [ImportDecl ()] -> ImportDecl an -> [Problem an]
validateImportDeclNoConflict prevDecls decl
  | any (`importsConflict` decl) prevDecls
  = [Conflict (getAnn decl) Term.Import $ pprintStr decl]
  | otherwise = []

validateRecordDeclNoDup :: (Semigroup an) => [RecordDecl ()] -> RecordDecl an -> [Problem an]
validateRecordDeclNoDup prevDecls decl
  | any (`declsConflict` decl) prevDecls
  = [Duplicate (getAnn decl) Term.RecordDecl $ pprintStr decl]
  | otherwise = []

validatePropNoDup :: (Semigroup an, FwdPrintable v, GenPropVal v)
                  => [GenProperty v ()]
                  -> GenProperty v an
                  -> [Problem an]
validatePropNoDup prevProps prop
  | any (`propsConflict` prop) prevProps = [Duplicate (getAnn prop) Term.Property $ pprintStr prop]
  | otherwise = []

-- | Whether both imports are redundant and/or could break each other.
importsConflict :: ImportDecl an1 -> ImportDecl an2 -> Bool
ImportDecl _ xPath xISrcs xIDsts `importsConflict` ImportDecl _ yPath yISrcs yIDsts
   = xPath =@= yPath
  && (isPermBy (=@=) xISrcs yISrcs || overlapsBy (=@=) xIDsts yIDsts)

-- | Whether both declarations' types conflict.
declsConflict :: RecordDecl an1 -> RecordDecl an2 -> Bool
RecordDecl _ x `declsConflict` RecordDecl _ y = x `typesConflict` y

-- | Whether both types have the same head - whether both types can't
-- exist in the same context.
typesConflict :: RecordType an1 -> RecordType an2 -> Bool
x `typesConflict` y = xHead =@= yHead && xHead /@= undefinedFSym
  where xHead = RecordType.head x
        yHead = RecordType.head y

-- | Whether both properties conflict - whether they can't be in the
-- same record.
propsConflict :: GenProperty v1 an1 -> GenProperty v2 an2 -> Bool
x `propsConflict` y = xKey =@= yKey && xKey /@= undefinedSym
  where xKey = propertyKey x
        yKey = propertyKey y

-- | Validates that the record's type was defined, and it conforms.
validateRecordConforms :: (Semigroup an) => RecordCtx () -> GenRecord v an -> [Problem an]
validateRecordConforms ctx (Record ann head' properties')
  = case recordTypeFor ctx head_ of
         Nothing -> [UndeclaredRecord (getAnn head') $ pprintStr head']
         Just (RecordType _ _ typeProps)
           -> validatePropsComplete typeProps ann properties'
           ++ validatePropsFit typeProps properties'
  where head_ = remAnns head'

validatePropsComplete :: (Semigroup an) => [Symbol ()] -> an -> [GenProperty v an] -> [Problem an]
validatePropsComplete typeProps ann properties'
  = case filter (not . (`assocMember` properties')) typeProps_ of
         [] -> []
         missingProps -> [IncompleteRecord ann $ map pprintStr missingProps]
  where typeProps_ = map remAnns typeProps

validatePropsFit :: (Semigroup an) => [Symbol ()] -> [GenProperty v an] -> [Problem an]
validatePropsFit declProps properties'
  = case deleteFirstsBy' (=@=) declProps propKeys of
         [] -> []
         extraKeys@(x : xs) -> [OvercompleteRecord extraKeysAnn $ extraKeyPrs]
           where extraKeyPrs = map pprintStr extraKeys
                 extraKeysAnn = sconcat $ NonEmpty.map getAnn extraKeys'
                 extraKeys' = x :| xs
  where propKeys = map propertyKey properties'

validatePathExists :: (Semigroup an) => In.Value () -> PropPath an -> [Problem an]
validatePathExists input' (PropPath _ elems)
  = validateSubpathExists (Just input') $ NonEmpty.toList elems

validateSubpathExists :: (Semigroup an) => Maybe (In.Value ()) -> [PathElem an] -> [Problem an]
validateSubpathExists _ [] = []
validateSubpathExists input' ((PathElem _ keyRef' headRef') : elems)
  = case recWithHead headRef_ =<< input' of
         Nothing -> [UndeclaredPathElemHead (getAnn headRef') $ pprintStr headRef']
         Just inRec
           -> case lookupProp keyRef_ inRec of
                   Nothing -> [UndeclaredPathElemKey (getAnn keyRef') $ pprintStr keyRef']
                   Just subInput -> validateSubpathExists subInput' elems
                     where subInput' = In.optValToMaybeVal subInput
  where headRef_ = remAnns headRef'
        keyRef_ = remAnns keyRef'

validateInjAppExists :: (Semigroup an) => Out.InjApp an -> [Problem an]
validateInjAppExists (Out.InjApp _ funcId' _)
  = case lookupFunc funcId' of
         Nothing -> [UndefinedInjFunc (getAnn funcId') $ pprintStr funcId']
         Just _ -> [] -- TODO Check params. Requires refactor move into `ValidatePropPaths`

recordTypeFor :: (Semigroup an) => RecordCtx an -> FSymbol an -> Maybe (RecordType an)
recordTypeFor (RecordCtx _ decls) head'
  = find (recordTypeMatches head') $ map recordDeclType decls

recordTypeMatches :: (Semigroup an) => FSymbol an -> RecordType an -> Bool
recordTypeMatches head' decl = head' =@= RecordType.head decl