1{-# LANGUAGE GADTs #-}
2module Spago.Dhall
3  ( module Spago.Dhall
4  , module Dhall
5  ) where
6
7import           Spago.Prelude
8
9import qualified Control.Monad.Trans.State.Strict      as State
10import qualified Data.Text                             as Text
11import qualified Data.Text.Prettyprint.Doc             as Pretty
12import qualified Data.Text.Prettyprint.Doc.Render.Text as PrettyText
13import           Dhall
14import           Dhall.Core                            as Dhall hiding (pretty)
15import qualified Dhall.Format
16import qualified Dhall.Import
17import qualified Dhall.Map
18import qualified Dhall.Parser                          as Parser
19import qualified Dhall.Pretty
20import           Dhall.TypeCheck                       (typeOf)
21import           Dhall.Util                            as Dhall
22import qualified Lens.Family
23import qualified System.FilePath                       as FilePath
24
25type DhallExpr a = Dhall.Expr Parser.Src a
26
27
28-- | Format a Dhall file in ASCII
29--   We first check if it's already formatted, if not we reformat it.
30format :: MonadIO m => Text -> m ()
31format pathText = liftIO $
32  try (f Dhall.Check) >>= \case
33    Left (_e :: SomeException) ->
34      f Dhall.Write
35    Right _ -> pure ()
36  where
37    f = Dhall.Format.format
38      . Dhall.Format.Format
39          (Just Dhall.Pretty.ASCII)
40          Dhall.NoCensor
41          (Dhall.PossiblyTransitiveInputFile (Text.unpack pathText) Dhall.NonTransitive)
42
43
44-- | Prettyprint a Dhall expression adding a comment on top
45prettyWithHeader :: Pretty.Pretty a => Dhall.Header -> DhallExpr a -> Dhall.Text
46prettyWithHeader (Header header) expr = do
47  let doc = Pretty.pretty header <> Pretty.pretty expr
48  PrettyText.renderStrict $ Pretty.layoutSmart Pretty.defaultLayoutOptions doc
49
50data TemplateComments = WithComments | NoComments
51
52processComments :: TemplateComments -> Text -> Text
53processComments WithComments = id
54processComments NoComments   = stripComments
55
56stripComments :: Text -> Text
57stripComments dhallSrc =
58  -- This is a hack taking advantage of current Dhall's parser behavior which does not preserve comments
59  -- This impl might need to be revisited after https://github.com/dhall-lang/dhall-haskell/issues/145 is fixed
60  case Parser.exprFromText mempty dhallSrc of
61    Left _     -> dhallSrc
62    Right expr -> pretty expr
63
64extractRecordValues
65  :: Dhall.Map.Map Text (Dhall.RecordField Parser.Src a)
66  -> Dhall.Map.Map Text (Dhall.Expr Parser.Src a)
67extractRecordValues = fmap (\Dhall.RecordField{..} -> recordFieldValue)
68
69-- | Return a list of all imports starting from a particular file
70readImports :: Text -> IO [Dhall.Import]
71readImports pathText = do
72  fileContents <- readTextFile $ pathFromText pathText
73  expr <- throws $ Parser.exprFromText mempty fileContents
74  status <- load expr
75  let graph = Lens.Family.view Dhall.Import.graph status
76  pure $ childImport <$> graph
77  where
78    load expr'
79      = State.execStateT
80          (Dhall.Import.loadWith expr')
81          (Dhall.Import.emptyStatus (FilePath.takeDirectory $ Text.unpack pathText))
82
83    childImport
84      = Dhall.Import.chainedImport . Dhall.Import.child
85
86
87
88readRawExpr :: Text -> IO (Maybe (Dhall.Header, DhallExpr Dhall.Import))
89readRawExpr pathText = do
90  exists <- testfile pathText
91  if exists
92    then (do
93      packageSetText <- readTextFile $ pathFromText pathText
94      fmap Just $ throws $ Parser.exprAndHeaderFromText mempty packageSetText)
95    else pure Nothing
96
97
98writeRawExpr :: Text -> (Dhall.Header, DhallExpr Dhall.Import) -> IO ()
99writeRawExpr pathText (header, expr) = do
100  -- Verify that the package set exists
101  -- If Dhall gets a 404, it will throw a PrettyHttpException
102  resolvedExpr <- Dhall.Import.load expr
103  -- After modifying the expression, we have to check if it still typechecks
104  -- if it doesn't we don't write to file.
105  _ <- throws (Dhall.TypeCheck.typeOf resolvedExpr)
106  writeTextFile pathText $ prettyWithHeader header expr
107  format pathText
108
109
110-- | Returns a Dhall Text literal from a lone string
111toTextLit :: Text -> DhallExpr a
112toTextLit str = Dhall.TextLit (Dhall.Chunks [] str)
113
114
115-- | Casts a Dhall Text literal to a string, or fails
116fromTextLit
117  :: (Typeable a)
118  => DhallExpr a
119  -> Either (ReadError a) Text
120fromTextLit(Dhall.TextLit (Dhall.Chunks [] str)) = Right str
121fromTextLit expr                                 = Left $ ExprIsNotTextLit expr
122
123
124-- | Require a key from a Dhall.Map, and run an action on it if found.
125--   If not found, return the name of the key.
126requireKey
127  :: (Typeable b, Pretty b, MonadThrow m)
128  => Dhall.Map.Map Text (DhallExpr b)
129  -> Text
130  -> (DhallExpr b -> m a)
131  -> m a
132requireKey ks name f = case Dhall.Map.lookup name ks of
133  Just v  -> f v
134  Nothing -> throwM (RequiredKeyMissing name ks)
135
136
137-- | Same as `requireKey`, but we give it a Dhall.Decoder to automagically decode from
138requireTypedKey
139  :: (MonadIO m, MonadThrow m)
140  => Dhall.Map.Map Text (DhallExpr Void)
141  -> Text
142  -> Dhall.Decoder a
143  -> m a
144requireTypedKey ks name typ = requireKey ks name $ \expr -> case Dhall.extract typ expr of
145  Success v -> pure v
146  Failure _ -> throwM $ RequiredKeyMissing name ks
147
148-- | Try to find a key from a Dhall.Map, and automagically decode the value with the given Dhall.Type
149--   If not found, return `Nothing`, if type is incorrect throw error
150maybeTypedKey
151  :: (MonadIO m, MonadThrow m)
152  => Dhall.Map.Map Text (DhallExpr Void)
153  -> Text
154  -> Dhall.Decoder a
155  -> m (Maybe a)
156maybeTypedKey ks name typ = typify `mapM` Dhall.Map.lookup name ks
157  where
158    typify expr = case Dhall.extract typ expr of
159      Success v -> pure v
160      Failure a -> throwM a
161
162
163-- | Spago configuration cannot be read
164data ReadError a where
165 -- | the toplevel value is not a record
166 ConfigIsNotRecord     :: Typeable a => DhallExpr a -> ReadError a
167 -- | the "packages" key is not a record
168 PackagesIsNotRecord   :: Typeable a => DhallExpr a -> ReadError a
169 -- | the "dependencies" key is not a list
170 DependenciesIsNotList :: Typeable a => DhallExpr a -> ReadError a
171 -- | the expression is not a Text Literal
172 ExprIsNotTextLit      :: Typeable a => DhallExpr a -> ReadError a
173 -- | the packages.dhall could not be parsed
174 CannotParsePackageSet :: Typeable a => DhallExpr a -> ReadError a
175 -- | the Import is not pointing to the right repo
176 ImportCannotBeUpdated :: Typeable a => Dhall.Import -> ReadError a
177 -- | a key is missing from a Dhall map
178 RequiredKeyMissing    :: Typeable a => Text -> Dhall.Map.Map Text (DhallExpr a) -> ReadError a
179
180instance (Pretty a, Typeable a) => Exception (ReadError a)
181
182instance (Pretty a) => Show (ReadError a) where
183  show err = Text.unpack $ Text.intercalate "\n" $
184    [ _ERROR <> ": Error while reading spago.dhall:"
185    , "" ]
186    <> msg err
187
188    where
189      msg :: ReadError a -> [Dhall.Text]
190      msg (PackagesIsNotRecord tl) =
191        [ "Explanation: The \"packages\" key must contain a record of packages."
192        , ""
193        , "The value was instead:"
194        , ""
195        , "↳ " <> pretty tl
196        ]
197      msg (DependenciesIsNotList e) =
198        [ "Explanation: The \"dependencies\" key must contain a list of package names."
199        , ""
200        , "The value was instead:"
201        , ""
202        , "↳ " <> pretty e
203        ]
204      msg (ConfigIsNotRecord tl) =
205        [ "Explanation: The config should be a record."
206        , ""
207        , "Its type is instead:"
208        , ""
209        , "↳ " <> pretty tl
210        ]
211      msg (RequiredKeyMissing key ks) =
212        [ "Explanation: a record is missing a required key."
213        , ""
214        , "The key missing is:"
215        , ""
216        , "↳ " <> key
217        , ""
218        , "The keys in the record are:"
219        , ""
220        , "↳ " <> (Text.intercalate ", " $ Dhall.Map.keys ks)
221        ]
222      msg (ExprIsNotTextLit e) =
223        [ "Explanation: the configuration contained a value that we expected to be"
224        , "a string, but wasn't."
225        , ""
226        , "The value was instead:"
227        , ""
228        , "↳ " <> pretty e
229        ]
230      msg (CannotParsePackageSet e) =
231        [ "Explanation: it was not possible to parse the `packages.dhall` file."
232        , ""
233        , "This is its Dhall expression:"
234        , ""
235        , "↳ " <> pretty e
236        ]
237      msg (ImportCannotBeUpdated imp) =
238        [ "Explanation: one of the imports in your `packages.dhall` file was not"
239        , "pointing to the purescript/package-sets repo, thus it couldn't be upgraded."
240        , ""
241        , "The import was:"
242        , ""
243        , "↳ " <> pretty (Dhall.Embed imp)
244        ]
245
246      _ERROR :: Dhall.Text
247      _ERROR = "\ESC[1;31mError\ESC[0m"
248