{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      : AOC.Discover
-- Copyright   : (c) Justin Le 2018
-- License     : BSD3
--
-- Maintainer  : justin@jle.im
-- Stability   : experimental
-- Portability : non-portable
--
-- Template Haskell for discovering all named challenges in a given
-- directory.
--

module AOC.Discover (
    mkChallengeMap
  , solutionList
  , ChallengeMap
  , ChallengeSpec(..)
  , solSpec
  , solSpecStr
  , solSpecStr_
  , charPart
  , challengeName
  , solverNFData
  , deepInstance
  ) where

import           AOC.Solver
import           Advent
import           Control.Applicative
import           Control.DeepSeq
import           Language.Haskell.TH.Datatype
import           Control.Monad
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import           Data.Bifunctor
import           Data.Data
import           Data.Map                   (Map)
import           Data.Maybe
import           Data.Traversable
import           Data.Void
import           GHC.Exts
import           Language.Haskell.Exts      as E
import           Language.Haskell.Names
import           Language.Haskell.TH        as TH
import           Language.Haskell.TH.Syntax (TExp(..))
import           Prelude
import           System.Directory
import           System.FilePath
import           Text.Printf
import qualified Data.List.NonEmpty         as NE
import qualified Data.Map                   as M
import qualified Hpack.Config               as H
import qualified Text.Megaparsec            as P
import qualified Text.Megaparsec.Char       as P
import qualified Text.Megaparsec.Char.Lexer as PL

-- | Big quick escape hatch if things explode in the middle of solving.
-- This will disable the check for NFData when using 'MkSomeSol' and assume
-- no NFData in every case.
checkIfNFData :: Bool
checkIfNFData :: Bool
checkIfNFData = Bool
True
-- checkIfNFData = False

-- | A specification for a specific challenge.  Should consist of a day and
-- a lowercase character.
data ChallengeSpec = CS { ChallengeSpec -> Day
_csDay  :: Day
                        , ChallengeSpec -> Part
_csPart :: Part
                        }
  deriving (Int -> ChallengeSpec -> String -> String
[ChallengeSpec] -> String -> String
ChallengeSpec -> String
(Int -> ChallengeSpec -> String -> String)
-> (ChallengeSpec -> String)
-> ([ChallengeSpec] -> String -> String)
-> Show ChallengeSpec
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ChallengeSpec] -> String -> String
$cshowList :: [ChallengeSpec] -> String -> String
show :: ChallengeSpec -> String
$cshow :: ChallengeSpec -> String
showsPrec :: Int -> ChallengeSpec -> String -> String
$cshowsPrec :: Int -> ChallengeSpec -> String -> String
Show, ChallengeSpec -> ChallengeSpec -> Bool
(ChallengeSpec -> ChallengeSpec -> Bool)
-> (ChallengeSpec -> ChallengeSpec -> Bool) -> Eq ChallengeSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChallengeSpec -> ChallengeSpec -> Bool
$c/= :: ChallengeSpec -> ChallengeSpec -> Bool
== :: ChallengeSpec -> ChallengeSpec -> Bool
$c== :: ChallengeSpec -> ChallengeSpec -> Bool
Eq, Eq ChallengeSpec
Eq ChallengeSpec
-> (ChallengeSpec -> ChallengeSpec -> Ordering)
-> (ChallengeSpec -> ChallengeSpec -> Bool)
-> (ChallengeSpec -> ChallengeSpec -> Bool)
-> (ChallengeSpec -> ChallengeSpec -> Bool)
-> (ChallengeSpec -> ChallengeSpec -> Bool)
-> (ChallengeSpec -> ChallengeSpec -> ChallengeSpec)
-> (ChallengeSpec -> ChallengeSpec -> ChallengeSpec)
-> Ord ChallengeSpec
ChallengeSpec -> ChallengeSpec -> Bool
ChallengeSpec -> ChallengeSpec -> Ordering
ChallengeSpec -> ChallengeSpec -> ChallengeSpec
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ChallengeSpec -> ChallengeSpec -> ChallengeSpec
$cmin :: ChallengeSpec -> ChallengeSpec -> ChallengeSpec
max :: ChallengeSpec -> ChallengeSpec -> ChallengeSpec
$cmax :: ChallengeSpec -> ChallengeSpec -> ChallengeSpec
>= :: ChallengeSpec -> ChallengeSpec -> Bool
$c>= :: ChallengeSpec -> ChallengeSpec -> Bool
> :: ChallengeSpec -> ChallengeSpec -> Bool
$c> :: ChallengeSpec -> ChallengeSpec -> Bool
<= :: ChallengeSpec -> ChallengeSpec -> Bool
$c<= :: ChallengeSpec -> ChallengeSpec -> Bool
< :: ChallengeSpec -> ChallengeSpec -> Bool
$c< :: ChallengeSpec -> ChallengeSpec -> Bool
compare :: ChallengeSpec -> ChallengeSpec -> Ordering
$ccompare :: ChallengeSpec -> ChallengeSpec -> Ordering
Ord)

-- | A map of days to parts to solutions.
type ChallengeMap = Map Day (Map Part SomeSolution)

-- | Get a 'ChallengeSpec' from a given reified solution (name).
--
-- @
-- solSpec \'day02a == CS { _csDay = 1, _csPart = 'a' }
-- @
--
solSpec :: TH.Name -> ChallengeSpec
solSpec :: Name -> ChallengeSpec
solSpec Name
n = String -> ChallengeSpec
solSpecStr_ (Name -> String
nameBase Name
n)

solSpecStr :: String -> Either (P.ParseErrorBundle String Void) ChallengeSpec
solSpecStr :: String -> Either (ParseErrorBundle String Void) ChallengeSpec
solSpecStr = Parsec Void String ChallengeSpec
-> String
-> String
-> Either (ParseErrorBundle String Void) ChallengeSpec
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.runParser Parsec Void String ChallengeSpec
challengeName String
""

solSpecStr_ :: String -> ChallengeSpec
solSpecStr_ :: String -> ChallengeSpec
solSpecStr_ = (ParseErrorBundle String Void -> ChallengeSpec)
-> (ChallengeSpec -> ChallengeSpec)
-> Either (ParseErrorBundle String Void) ChallengeSpec
-> ChallengeSpec
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> ChallengeSpec
forall a. HasCallStack => String -> a
error (String -> ChallengeSpec)
-> (ParseErrorBundle String Void -> String)
-> ParseErrorBundle String Void
-> ChallengeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle String Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
P.errorBundlePretty) ChallengeSpec -> ChallengeSpec
forall a. a -> a
id (Either (ParseErrorBundle String Void) ChallengeSpec
 -> ChallengeSpec)
-> (String -> Either (ParseErrorBundle String Void) ChallengeSpec)
-> String
-> ChallengeSpec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either (ParseErrorBundle String Void) ChallengeSpec
solSpecStr

instance IsString ChallengeSpec where
    fromString :: String -> ChallengeSpec
fromString = String -> ChallengeSpec
solSpecStr_

type Parser = P.Parsec Void String

-- | Template Haskell splice to produce a list of all named solutions in
-- a directory. Expects solutions as function names following the format
-- @dayDDp@, where @DD@ is a two-digit zero-added day, and @p@ is
-- a lower-case letter corresponding to the part of the challenge.
--
-- See 'mkChallengeMap' for a description of usage.
solutionList :: FilePath -> Code Q [(Day, (Part, SomeSolution))]
solutionList :: String -> Code Q [(Day, (Part, SomeSolution))]
solutionList String
dir = Q (TExp [(Day, (Part, SomeSolution))])
-> Code Q [(Day, (Part, SomeSolution))]
forall (m :: * -> *) a. m (TExp a) -> Code m a
Code (Q (TExp [(Day, (Part, SomeSolution))])
 -> Code Q [(Day, (Part, SomeSolution))])
-> Q (TExp [(Day, (Part, SomeSolution))])
-> Code Q [(Day, (Part, SomeSolution))]
forall a b. (a -> b) -> a -> b
$
         ([Exp] -> TExp [(Day, (Part, SomeSolution))])
-> Q [Exp] -> Q (TExp [(Day, (Part, SomeSolution))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> TExp [(Day, (Part, SomeSolution))]
forall a. Exp -> TExp a
TExp (Exp -> TExp [(Day, (Part, SomeSolution))])
-> ([Exp] -> Exp) -> [Exp] -> TExp [(Day, (Part, SomeSolution))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
ListE)
       (Q [Exp] -> Q (TExp [(Day, (Part, SomeSolution))]))
-> ([ChallengeSpec] -> Q [Exp])
-> [ChallengeSpec]
-> Q (TExp [(Day, (Part, SomeSolution))])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChallengeSpec -> Q Exp) -> [ChallengeSpec] -> Q [Exp]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((TExp (Day, (Part, SomeSolution)) -> Exp)
-> Q (TExp (Day, (Part, SomeSolution))) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TExp (Day, (Part, SomeSolution)) -> Exp
forall a. TExp a -> Exp
unType (Q (TExp (Day, (Part, SomeSolution))) -> Q Exp)
-> (ChallengeSpec -> Q (TExp (Day, (Part, SomeSolution))))
-> ChallengeSpec
-> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChallengeSpec -> Q (TExp (Day, (Part, SomeSolution)))
specExp)
     ([ChallengeSpec] -> Q (TExp [(Day, (Part, SomeSolution))]))
-> Q [ChallengeSpec] -> Q (TExp [(Day, (Part, SomeSolution))])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [ChallengeSpec] -> Q [ChallengeSpec]
forall a. IO a -> Q a
runIO (String -> IO [ChallengeSpec]
getChallengeSpecs String
dir)

-- | Meant to be called like:
--
-- @
-- mkChallengeMap $$(solutionList "src\/AOC\/Challenge")
-- @
mkChallengeMap :: [(Day, (Part, SomeSolution))] -> ChallengeMap
mkChallengeMap :: [(Day, (Part, SomeSolution))] -> ChallengeMap
mkChallengeMap = (Map Part SomeSolution
 -> Map Part SomeSolution -> Map Part SomeSolution)
-> [ChallengeMap] -> ChallengeMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith Map Part SomeSolution
-> Map Part SomeSolution -> Map Part SomeSolution
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union
               ([ChallengeMap] -> ChallengeMap)
-> ([(Day, (Part, SomeSolution))] -> [ChallengeMap])
-> [(Day, (Part, SomeSolution))]
-> ChallengeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Day, (Part, SomeSolution)) -> ChallengeMap)
-> [(Day, (Part, SomeSolution))] -> [ChallengeMap]
forall a b. (a -> b) -> [a] -> [b]
map ((Day -> Map Part SomeSolution -> ChallengeMap)
-> (Day, Map Part SomeSolution) -> ChallengeMap
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Day -> Map Part SomeSolution -> ChallengeMap
forall k a. k -> a -> Map k a
M.singleton ((Day, Map Part SomeSolution) -> ChallengeMap)
-> ((Day, (Part, SomeSolution)) -> (Day, Map Part SomeSolution))
-> (Day, (Part, SomeSolution))
-> ChallengeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Part, SomeSolution) -> Map Part SomeSolution)
-> (Day, (Part, SomeSolution)) -> (Day, Map Part SomeSolution)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Part -> SomeSolution -> Map Part SomeSolution)
-> (Part, SomeSolution) -> Map Part SomeSolution
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Part -> SomeSolution -> Map Part SomeSolution
forall k a. k -> a -> Map k a
M.singleton))


specExp :: ChallengeSpec -> Q (TExp (Day, (Part, SomeSolution)))
specExp :: ChallengeSpec -> Q (TExp (Day, (Part, SomeSolution)))
specExp s :: ChallengeSpec
s@(CS Day
d Part
p) = do
    Maybe Name
n <- String -> Q (Maybe Name)
lookupValueName (ChallengeSpec -> String
specName ChallengeSpec
s)
    Name
con <- case Maybe Name
n of
      Maybe Name
Nothing -> Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure 'MkSomeSolWH
      Just Name
n' -> do
        Bool
isNF <- Name -> Q Bool
solverNFData Name
n'
        pure $ if Bool
isNF
                 then 'MkSomeSolNF
                 else 'MkSomeSolWH
    pure $ Exp -> TExp (Day, (Part, SomeSolution))
forall a. Exp -> TExp a
TExp (Exp -> TExp (Day, (Part, SomeSolution)))
-> Exp -> TExp (Day, (Part, SomeSolution))
forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TupE
      [ Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE 'mkDay_ Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (Integer -> Lit
IntegerL (Day -> Integer
dayInt Day
d))
      , Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TupE
          [ Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE (Part -> Name
partCon Part
p)
          , Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
con Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE (String -> Name
mkName (ChallengeSpec -> String
specName ChallengeSpec
s))
          ]
      ]
  where
    partCon :: Part -> Name
partCon Part
Part1 = 'Part1
    partCon Part
Part2 = 'Part2

specName :: ChallengeSpec -> String
specName :: ChallengeSpec -> String
specName (CS Day
d Part
p) = String -> Integer -> Char -> String
forall r. PrintfType r => String -> r
printf String
"day%02d%c" (Day -> Integer
dayInt Day
d) (Part -> Char
partChar Part
p)

getChallengeSpecs
    :: FilePath                 -- ^ directory of modules
    -> IO [ChallengeSpec]       -- ^ all challenge specs found
getChallengeSpecs :: String -> IO [ChallengeSpec]
getChallengeSpecs String
dir = do
    [Extension]
exts   <- IO [Extension]
defaultExtensions
    [String]
files  <- String -> IO [String]
listDirectory String
dir
    [Module SrcSpanInfo]
parsed <- [String]
-> (String -> IO (Module SrcSpanInfo)) -> IO [Module SrcSpanInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
files ((String -> IO (Module SrcSpanInfo)) -> IO [Module SrcSpanInfo])
-> (String -> IO (Module SrcSpanInfo)) -> IO [Module SrcSpanInfo]
forall a b. (a -> b) -> a -> b
$ \String
f -> do
      let mode :: ParseMode
mode = ParseMode
defaultParseMode { extensions :: [Extension]
extensions    = [Extension]
exts
                                  , fixities :: Maybe [Fixity]
fixities      = [Fixity] -> Maybe [Fixity]
forall a. a -> Maybe a
Just []
                                  , parseFilename :: String
parseFilename = String
f
                                  }
      ParseResult (Module SrcSpanInfo)
res <- ParseMode -> String -> IO (ParseResult (Module SrcSpanInfo))
parseFileWithMode ParseMode
mode (String
dir String -> String -> String
</> String
f)
      case ParseResult (Module SrcSpanInfo)
res of
        ParseOk Module SrcSpanInfo
x       -> Module SrcSpanInfo -> IO (Module SrcSpanInfo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Module SrcSpanInfo
x
        ParseFailed SrcLoc
l String
e -> String -> IO (Module SrcSpanInfo)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Module SrcSpanInfo))
-> String -> IO (Module SrcSpanInfo)
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Failed parsing %s at %s: %s" String
f (SrcLoc -> String
forall a. Show a => a -> String
show SrcLoc
l) String
e
    pure $ [Module SrcSpanInfo] -> [ChallengeSpec]
forall l. (Data l, Eq l) => [Module l] -> [ChallengeSpec]
moduleSolutions [Module SrcSpanInfo]
parsed

defaultExtensions :: IO [E.Extension]
defaultExtensions :: IO [Extension]
defaultExtensions = do
    Right H.DecodeResult{String
[String]
Package
decodeResultWarnings :: DecodeResult -> [String]
decodeResultPackage :: DecodeResult -> Package
decodeResultCabalVersion :: DecodeResult -> String
decodeResultCabalFile :: DecodeResult -> String
decodeResultWarnings :: [String]
decodeResultCabalFile :: String
decodeResultCabalVersion :: String
decodeResultPackage :: Package
..} <- DecodeOptions -> IO (Either String DecodeResult)
H.readPackageConfig DecodeOptions
H.defaultDecodeOptions
    Just H.Section{[String]
[Conditional (Section Library)]
[Path]
[Verbatim]
Maybe Bool
Map BuildTool DependencyVersion
Library
SystemBuildTools
Dependencies
sectionVerbatim :: forall a. Section a -> [Verbatim]
sectionSystemBuildTools :: forall a. Section a -> SystemBuildTools
sectionSourceDirs :: forall a. Section a -> [String]
sectionPkgConfigDependencies :: forall a. Section a -> [String]
sectionOtherExtensions :: forall a. Section a -> [String]
sectionLdOptions :: forall a. Section a -> [String]
sectionJsSources :: forall a. Section a -> [Path]
sectionInstallIncludes :: forall a. Section a -> [String]
sectionIncludeDirs :: forall a. Section a -> [String]
sectionGhcjsOptions :: forall a. Section a -> [String]
sectionGhcProfOptions :: forall a. Section a -> [String]
sectionGhcOptions :: forall a. Section a -> [String]
sectionFrameworks :: forall a. Section a -> [String]
sectionExtraLibraries :: forall a. Section a -> [String]
sectionExtraLibDirs :: forall a. Section a -> [String]
sectionExtraFrameworksDirs :: forall a. Section a -> [String]
sectionDependencies :: forall a. Section a -> Dependencies
sectionDefaultExtensions :: forall a. Section a -> [String]
sectionData :: forall a. Section a -> a
sectionCxxSources :: forall a. Section a -> [Path]
sectionCxxOptions :: forall a. Section a -> [String]
sectionCppOptions :: forall a. Section a -> [String]
sectionConditionals :: forall a. Section a -> [Conditional (Section a)]
sectionCcOptions :: forall a. Section a -> [String]
sectionCSources :: forall a. Section a -> [Path]
sectionBuildable :: forall a. Section a -> Maybe Bool
sectionBuildTools :: forall a. Section a -> Map BuildTool DependencyVersion
sectionVerbatim :: [Verbatim]
sectionSystemBuildTools :: SystemBuildTools
sectionBuildTools :: Map BuildTool DependencyVersion
sectionConditionals :: [Conditional (Section Library)]
sectionBuildable :: Maybe Bool
sectionLdOptions :: [String]
sectionInstallIncludes :: [String]
sectionIncludeDirs :: [String]
sectionFrameworks :: [String]
sectionExtraFrameworksDirs :: [String]
sectionExtraLibraries :: [String]
sectionExtraLibDirs :: [String]
sectionJsSources :: [Path]
sectionCxxSources :: [Path]
sectionCxxOptions :: [String]
sectionCSources :: [Path]
sectionCcOptions :: [String]
sectionCppOptions :: [String]
sectionGhcjsOptions :: [String]
sectionGhcProfOptions :: [String]
sectionGhcOptions :: [String]
sectionOtherExtensions :: [String]
sectionDefaultExtensions :: [String]
sectionPkgConfigDependencies :: [String]
sectionDependencies :: Dependencies
sectionSourceDirs :: [String]
sectionData :: Library
..} <- Maybe (Section Library) -> IO (Maybe (Section Library))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Section Library) -> IO (Maybe (Section Library)))
-> Maybe (Section Library) -> IO (Maybe (Section Library))
forall a b. (a -> b) -> a -> b
$ Package -> Maybe (Section Library)
H.packageLibrary Package
decodeResultPackage
    [Extension] -> IO [Extension]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Extension] -> IO [Extension]) -> [Extension] -> IO [Extension]
forall a b. (a -> b) -> a -> b
$ String -> Extension
parseExtension (String -> Extension) -> [String] -> [Extension]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
sectionDefaultExtensions

moduleSolutions :: (Data l, Eq l) => [Module l] -> [ChallengeSpec]
moduleSolutions :: forall l. (Data l, Eq l) => [Module l] -> [ChallengeSpec]
moduleSolutions = (([Symbol] -> [ChallengeSpec])
-> Map (ModuleName ()) [Symbol] -> [ChallengeSpec]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (([Symbol] -> [ChallengeSpec])
 -> Map (ModuleName ()) [Symbol] -> [ChallengeSpec])
-> ((Symbol -> [ChallengeSpec]) -> [Symbol] -> [ChallengeSpec])
-> (Symbol -> [ChallengeSpec])
-> Map (ModuleName ()) [Symbol]
-> [ChallengeSpec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Symbol -> [ChallengeSpec]) -> [Symbol] -> [ChallengeSpec]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap) (Maybe ChallengeSpec -> [ChallengeSpec]
forall a. Maybe a -> [a]
maybeToList (Maybe ChallengeSpec -> [ChallengeSpec])
-> (Symbol -> Maybe ChallengeSpec) -> Symbol -> [ChallengeSpec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Symbol -> Maybe ChallengeSpec
isSolution)
                (Map (ModuleName ()) [Symbol] -> [ChallengeSpec])
-> ([Module l] -> Map (ModuleName ()) [Symbol])
-> [Module l]
-> [ChallengeSpec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Module l]
 -> Map (ModuleName ()) [Symbol] -> Map (ModuleName ()) [Symbol])
-> Map (ModuleName ()) [Symbol]
-> [Module l]
-> Map (ModuleName ()) [Symbol]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Module l]
-> Map (ModuleName ()) [Symbol] -> Map (ModuleName ()) [Symbol]
forall l.
(Data l, Eq l) =>
[Module l]
-> Map (ModuleName ()) [Symbol] -> Map (ModuleName ()) [Symbol]
resolve Map (ModuleName ()) [Symbol]
forall k a. Map k a
M.empty


isSolution :: Symbol -> Maybe ChallengeSpec
isSolution :: Symbol -> Maybe ChallengeSpec
isSolution Symbol
s = do
    Value ModuleName ()
_ (Ident ()
_ String
n) <- Symbol -> Maybe Symbol
forall (f :: * -> *) a. Applicative f => a -> f a
pure Symbol
s
    Right ChallengeSpec
c             <- Either (ParseErrorBundle String Void) ChallengeSpec
-> Maybe (Either (ParseErrorBundle String Void) ChallengeSpec)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ParseErrorBundle String Void) ChallengeSpec
 -> Maybe (Either (ParseErrorBundle String Void) ChallengeSpec))
-> Either (ParseErrorBundle String Void) ChallengeSpec
-> Maybe (Either (ParseErrorBundle String Void) ChallengeSpec)
forall a b. (a -> b) -> a -> b
$ Parsec Void String ChallengeSpec
-> String
-> String
-> Either (ParseErrorBundle String Void) ChallengeSpec
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
P.runParser Parsec Void String ChallengeSpec
challengeName String
"" String
n
    ChallengeSpec -> Maybe ChallengeSpec
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChallengeSpec
c

challengeName :: Parser ChallengeSpec
challengeName :: Parsec Void String ChallengeSpec
challengeName = do
    String
_    <- Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
P.string String
Tokens String
"day"
    Integer
dInt <- ParsecT Void String Identity Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
PL.decimal
    Day
dFin <- ParsecT Void String Identity Day
-> (Day -> ParsecT Void String Identity Day)
-> Maybe Day
-> ParsecT Void String Identity Day
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ParsecT Void String Identity Day
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void String Identity Day)
-> String -> ParsecT Void String Identity Day
forall a b. (a -> b) -> a -> b
$ String
"Day not in range: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
dInt) Day -> ParsecT Void String Identity Day
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Day -> ParsecT Void String Identity Day)
-> Maybe Day -> ParsecT Void String Identity Day
forall a b. (a -> b) -> a -> b
$
                Integer -> Maybe Day
mkDay Integer
dInt
    Char
c    <- ParsecT Void String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
P.lowerChar
    Part
p    <- ParsecT Void String Identity Part
-> (Part -> ParsecT Void String Identity Part)
-> Maybe Part
-> ParsecT Void String Identity Part
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ParsecT Void String Identity Part
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void String Identity Part)
-> String -> ParsecT Void String Identity Part
forall a b. (a -> b) -> a -> b
$ String -> Char -> String
forall r. PrintfType r => String -> r
printf String
"Part not parsed: %c" Char
c) Part -> ParsecT Void String Identity Part
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Part -> ParsecT Void String Identity Part)
-> Maybe Part -> ParsecT Void String Identity Part
forall a b. (a -> b) -> a -> b
$
                Char -> Maybe Part
charPart Char
c
    pure $ Day -> Part -> ChallengeSpec
CS Day
dFin Part
p

-- | Parse a 'Char' into a 'Part'
charPart :: Char -> Maybe Part
charPart :: Char -> Maybe Part
charPart Char
'a' = Part -> Maybe Part
forall a. a -> Maybe a
Just Part
Part1
charPart Char
'b' = Part -> Maybe Part
forall a. a -> Maybe a
Just Part
Part2
charPart Char
_   = Maybe Part
forall a. Maybe a
Nothing

-- | Check if a solver identifier is of type @A ':~>' B@, where @B@ is an
-- instance of 'NFData'.
solverNFData :: TH.Name -> Q Bool
solverNFData :: Name -> Q Bool
solverNFData Name
n
  | Bool
checkIfNFData = Name -> Q Info
reify Name
n Q Info -> (Info -> Q Bool) -> Q Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      VarI Name
_ (ConT Name
c `AppT` Type
a `AppT` Type
_) Maybe Dec
_
        | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''(:~>) -> Name -> Type -> Q Bool
deepInstance ''NFData Type
a
      Info
_ -> Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  | Bool
otherwise     = Bool -> Q Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | Check if a type is an instance of a class, unifying when possible
deepInstance
    :: TH.Name  -- ^ class
    -> TH.Type  -- ^ type
    -> Q Bool
deepInstance :: Name -> Type -> Q Bool
deepInstance Name
cn = (Maybe () -> Bool) -> Q (Maybe ()) -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Q (Maybe ()) -> Q Bool)
-> (Type -> Q (Maybe ())) -> Type -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT Q () -> Q (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Q () -> Q (Maybe ()))
-> (Type -> MaybeT Q ()) -> Type -> Q (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type -> MaybeT Q ()
deepInstance_ Name
cn

deepInstance_
    :: TH.Name  -- ^ class
    -> TH.Type  -- ^ type
    -> MaybeT Q ()
deepInstance_ :: Name -> Type -> MaybeT Q ()
deepInstance_ Name
cn Type
t = do
    NonEmpty Dec
insts <- MaybeT Q (NonEmpty Dec)
-> (NonEmpty Dec -> MaybeT Q (NonEmpty Dec))
-> Maybe (NonEmpty Dec)
-> MaybeT Q (NonEmpty Dec)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MaybeT Q (NonEmpty Dec)
forall (f :: * -> *) a. Alternative f => f a
empty NonEmpty Dec -> MaybeT Q (NonEmpty Dec)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (NonEmpty Dec) -> MaybeT Q (NonEmpty Dec))
-> ([Dec] -> Maybe (NonEmpty Dec))
-> [Dec]
-> MaybeT Q (NonEmpty Dec)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dec] -> Maybe (NonEmpty Dec)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty ([Dec] -> MaybeT Q (NonEmpty Dec))
-> MaybeT Q [Dec] -> MaybeT Q (NonEmpty Dec)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q [Dec] -> MaybeT Q [Dec]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Name -> [Type] -> Q [Dec]
reifyInstances Name
cn [Type
t])
    NonEmpty Dec -> (Dec -> MaybeT Q ()) -> MaybeT Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty Dec
insts ((Dec -> MaybeT Q ()) -> MaybeT Q ())
-> (Dec -> MaybeT Q ()) -> MaybeT Q ()
forall a b. (a -> b) -> a -> b
$ \case
      InstanceD Maybe Overlap
_ [Type]
ctx Type
instHead [Dec]
_ -> do
        Map Name Type
uni <- Q (Map Name Type) -> MaybeT Q (Map Name Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q (Map Name Type) -> MaybeT Q (Map Name Type))
-> Q (Map Name Type) -> MaybeT Q (Map Name Type)
forall a b. (a -> b) -> a -> b
$ [Type] -> Q (Map Name Type)
unifyTypes [Name -> Type
ConT Name
cn Type -> Type -> Type
`AppT` Type
t, Type
instHead]
        [Type] -> (Type -> MaybeT Q ()) -> MaybeT Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Type]
ctx ((Type -> MaybeT Q ()) -> MaybeT Q ())
-> (Type -> MaybeT Q ()) -> MaybeT Q ()
forall a b. (a -> b) -> a -> b
$ \case
          AppT (ConT Name
c) Type
v -> Name -> Type -> MaybeT Q ()
deepInstance_ Name
c (Map Name Type -> Type -> Type
forall a. TypeSubstitution a => Map Name Type -> a -> a
applySubstitution Map Name Type
uni Type
v)
          Type
_               -> MaybeT Q ()
forall (f :: * -> *) a. Alternative f => f a
empty
      Dec
_                            -> MaybeT Q ()
forall (f :: * -> *) a. Alternative f => f a
empty